, existinghooks :: M.Map Git.Hook.Hook Bool
, workers :: Maybe (TMVar (WorkerPool (AnnexState, AnnexRead)))
, cachedcurrentbranch :: (Maybe (Maybe Git.Branch, Maybe Adjustment))
- , cachedgitenv :: Maybe (AltIndexFile, FilePath, [(String, String)])
+ , cachedgitenv :: Maybe (AltIndexFile, OsPath, [(String, String)])
, urloptions :: Maybe UrlOptions
, insmudgecleanfilter :: Bool
, getvectorclock :: IO CandidateVectorClock
- because the git repo paths are stored relative.
- Instead, use this.
-}
-changeDirectory :: FilePath -> Annex ()
+changeDirectory :: OsPath -> Annex ()
changeDirectory d = do
r <- liftIO . Git.adjustPath absPath =<< gitRepo
liftIO $ setCurrentDirectory d
Database.Keys.addAssociatedFile k f
exe <- catchDefaultIO False $
(isExecutable . fileMode) <$>
- (liftIO . R.getFileStatus
+ (liftIO . R.getFileStatus . fromOsPath
=<< calcRepo (gitAnnexLocation k))
let mode = fromTreeItemType $
if exe then TreeExecutable else TreeFile
adjustToSymlink :: TreeItem -> Annex (Maybe TreeItem)
adjustToSymlink = adjustToSymlink' gitAnnexLink
-adjustToSymlink' :: (RawFilePath -> Key -> Git.Repo -> GitConfig -> IO RawFilePath) -> TreeItem -> Annex (Maybe TreeItem)
+adjustToSymlink' :: (OsPath -> Key -> Git.Repo -> GitConfig -> IO OsPath) -> TreeItem -> Annex (Maybe TreeItem)
adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case
Just k -> do
absf <- inRepo $ \r -> absPath $ fromTopFilePath f r
linktarget <- calcRepo $ gitannexlink absf k
Just . TreeItem f (fromTreeItemType TreeSymlink)
- <$> hashSymlink linktarget
+ <$> hashSymlink (fromOsPath linktarget)
Nothing -> return (Just ti)
-- This is a hidden branch ref, that's used as the basis for the AdjBranch,
-- origbranch.
_ <- propigateAdjustedCommits' True origbranch adj commitlck
- origheadfile <- inRepo $ F.readFile' . toOsPath . Git.Ref.headFile
+ origheadfile <- inRepo $ F.readFile' . Git.Ref.headFile
origheadsha <- inRepo (Git.Ref.sha currbranch)
b <- adjustBranch adj origbranch
Just s -> do
inRepo $ \r -> do
let newheadfile = fromRef' s
- F.writeFile' (toOsPath (Git.Ref.headFile r)) newheadfile
+ F.writeFile' (Git.Ref.headFile r) newheadfile
return (Just newheadfile)
_ -> return Nothing
unless ok $ case newheadfile of
Nothing -> noop
Just v -> preventCommits $ \_commitlck -> inRepo $ \r -> do
- v' <- F.readFile' (toOsPath (Git.Ref.headFile r))
+ v' <- F.readFile' (Git.Ref.headFile r)
when (v == v') $
- F.writeFile' (toOsPath (Git.Ref.headFile r)) origheadfile
+ F.writeFile' (Git.Ref.headFile r) origheadfile
return ok
| otherwise = preventCommits $ \commitlck -> do
where
setup = do
lck <- fromRepo $ indexFileLock . indexFile
- liftIO $ Git.LockFile.openLock (fromRawFilePath lck)
+ liftIO $ Git.LockFile.openLock lck
cleanup = liftIO . Git.LockFile.closeLock
{- Commits a given adjusted tree, with the provided parent ref.
where
m = M.fromList $ map (\i@(TreeItem f' _ _) -> (norm f', i)) $
map diffTreeToTreeItem changes
- norm = normalise . fromRawFilePath . getTopFilePath
+ norm = normalise . getTopFilePath
diffTreeToTreeItem :: Git.DiffTree.DiffTreeItem -> TreeItem
diffTreeToTreeItem dti = TreeItem
import Utility.Tmp.Dir
import Utility.CopyFile
import Utility.Directory.Create
-import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
-import qualified System.FilePath.ByteString as P
-
canMergeToAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> Annex Bool
canMergeToAdjustedBranch tomerge (origbranch, adj) =
inRepo $ Git.Branch.changed currbranch tomerge
changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do
git_dir <- fromRepo Git.localGitDir
tmpwt <- fromRepo gitAnnexMergeDir
- withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "git") $ \tmpgit -> withWorkTreeRelated tmpgit $
+ withTmpDirIn othertmpdir (literalOsPath "git") $ \tmpgit -> withWorkTreeRelated tmpgit $
withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do
- let tmpgit' = toRawFilePath tmpgit
- liftIO $ writeFile (tmpgit </> "HEAD") (fromRef updatedorig)
+ liftIO $ F.writeFile'
+ (tmpgit </> literalOsPath "HEAD")
+ (fromRef' updatedorig)
-- Copy in refs and packed-refs, to work
-- around bug in git 2.13.0, which
-- causes it not to look in GIT_DIR for refs.
refs <- liftIO $ emptyWhenDoesNotExist $
dirContentsRecursive $
- git_dir P.</> "refs"
- let refs' = (git_dir P.</> "packed-refs") : refs
+ git_dir </> literalOsPath "refs"
+ let refs' = (git_dir </> literalOsPath "packed-refs") : refs
liftIO $ forM_ refs' $ \src -> do
- whenM (R.doesPathExist src) $ do
+ whenM (doesFileExist src) $ do
dest <- relPathDirToFile git_dir src
- let dest' = tmpgit' P.</> dest
+ let dest' = tmpgit </> dest
createDirectoryUnder [git_dir]
- (P.takeDirectory dest')
+ (takeDirectory dest')
void $ createLinkOrCopy src dest'
-- This reset makes git merge not care
-- that the work tree is empty; otherwise
if merged
then do
!mergecommit <- liftIO $ extractSha
- <$> F.readFile' (toOsPath (tmpgit' P.</> "HEAD"))
+ <$> F.readFile' (tmpgit </> literalOsPath "HEAD")
-- This is run after the commit lock is dropped.
return $ postmerge mergecommit
else return $ return False
setup = do
whenM (doesDirectoryExist d) $
removeDirectoryRecursive d
- createDirectoryUnder [git_dir] (toRawFilePath d)
+ createDirectoryUnder [git_dir] d
cleanup _ = removeDirectoryRecursive d
{- A merge commit has been made between the basisbranch and
resolveMerge :: Maybe Git.Ref -> Git.Ref -> Bool -> Annex Bool
resolveMerge us them inoverlay = do
top <- if inoverlay
- then pure "."
+ then pure (literalOsPath ".")
else fromRepo Git.repoPath
(fs, cleanup) <- inRepo (LsFiles.unmerged [top])
srcmap <- if inoverlay
unless (null deleted) $
Annex.Queue.addCommand [] "rm"
[Param "--quiet", Param "-f", Param "--"]
- (map fromRawFilePath deleted)
+ (map fromOsPath deleted)
void $ liftIO cleanup2
when merged $ do
, LsFiles.unmergedSiblingFile u
]
-resolveMerge' :: InodeMap -> Maybe Git.Ref -> Git.Ref -> Bool -> LsFiles.Unmerged -> Annex ([Key], Maybe FilePath)
+resolveMerge' :: InodeMap -> Maybe Git.Ref -> Git.Ref -> Bool -> LsFiles.Unmerged -> Annex ([Key], Maybe OsPath)
resolveMerge' _ Nothing _ _ _ = return ([], Nothing)
resolveMerge' unstagedmap (Just us) them inoverlay u = do
kus <- getkey LsFiles.valUs
-- files, so delete here.
unless inoverlay $
unless (islocked LsFiles.valUs) $
- liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath file)
+ liftIO $ removeWhenExistsWith removeFile file
| otherwise -> resolveby [keyUs, keyThem] $
-- Only resolve using symlink when both
-- were locked, otherwise use unlocked
-- Neither side is annexed file; cannot resolve.
(Nothing, Nothing) -> return ([], Nothing)
where
- file = fromRawFilePath $ LsFiles.unmergedFile u
- sibfile = fromRawFilePath <$> LsFiles.unmergedSiblingFile u
+ file = LsFiles.unmergedFile u
+ sibfile = LsFiles.unmergedSiblingFile u
getkey select =
case select (LsFiles.unmergedSha u) of
dest = variantFile file key
destmode = fromTreeItemType <$> select (LsFiles.unmergedTreeItemType u)
- stagefile :: FilePath -> Annex FilePath
+ stagefile :: OsPath -> Annex OsPath
stagefile f
- | inoverlay = (</> f) . fromRawFilePath <$> fromRepo Git.repoPath
+ | inoverlay = (</> f) <$> fromRepo Git.repoPath
| otherwise = pure f
makesymlink key dest = do
- let rdest = toRawFilePath dest
- l <- calcRepo $ gitAnnexLink rdest key
- unless inoverlay $ replacewithsymlink rdest l
- dest' <- toRawFilePath <$> stagefile dest
+ l <- fromOsPath <$> calcRepo (gitAnnexLink dest key)
+ unless inoverlay $ replacewithsymlink dest l
+ dest' <- stagefile dest
stageSymlink dest' =<< hashSymlink l
replacewithsymlink dest link = replaceWorkTreeFile dest $
makepointer key dest destmode = do
unless inoverlay $
unlessM (reuseOldFile unstagedmap key file dest) $
- linkFromAnnex key (toRawFilePath dest) destmode >>= \case
+ linkFromAnnex key dest destmode >>= \case
LinkAnnexFailed -> liftIO $
- writePointerFile (toRawFilePath dest) key destmode
+ writePointerFile dest key destmode
_ -> noop
- dest' <- toRawFilePath <$> stagefile dest
+ dest' <- stagefile dest
stagePointerFile dest' destmode =<< hashPointerFile key
unless inoverlay $
Database.Keys.addAssociatedFile key
- =<< inRepo (toTopFilePath (toRawFilePath dest))
+ =<< inRepo (toTopFilePath dest)
{- Stage a graft of a directory or file from a branch
- and update the work tree. -}
graftin b item selectwant selectwant' selectunwant = do
Annex.Queue.addUpdateIndex
- =<< fromRepo (UpdateIndex.lsSubTree b item)
-
+ =<< fromRepo (UpdateIndex.lsSubTree b (fromOsPath item))
+
let replacefile isexecutable = case selectwant' (LsFiles.unmergedSha u) of
Nothing -> noop
- Just sha -> replaceWorkTreeFile (toRawFilePath item) $ \tmp -> do
+ Just sha -> replaceWorkTreeFile item $ \tmp -> do
c <- catObject sha
- liftIO $ F.writeFile (toOsPath tmp) c
+ liftIO $ F.writeFile tmp c
when isexecutable $
liftIO $ void $ tryIO $
modifyFileMode tmp $
Nothing -> noop
Just sha -> do
link <- catSymLinkTarget sha
- replacewithsymlink (toRawFilePath item) link
+ replacewithsymlink item (fromOsPath link)
(Just TreeFile, Just TreeSymlink) -> replacefile False
(Just TreeExecutable, Just TreeSymlink) -> replacefile True
_ -> ifM (liftIO $ doesDirectoryExist item)
, Param "--cached"
, Param "--"
]
- (catMaybes [Just file, sibfile])
+ (map fromOsPath $ catMaybes [Just file, sibfile])
liftIO $ maybe noop
- (removeWhenExistsWith R.removeLink . toRawFilePath)
+ (removeWhenExistsWith removeFile)
sibfile
void a
return (ks, Just file)
- C) are pointers to or have the content of keys that were involved
- in the merge.
-}
-cleanConflictCruft :: [Key] -> [FilePath] -> InodeMap -> Annex ()
+cleanConflictCruft :: [Key] -> [OsPath] -> InodeMap -> Annex ()
cleanConflictCruft resolvedks resolvedfs unstagedmap = do
is <- S.fromList . map (inodeCacheToKey Strongly) . concat
<$> mapM Database.Keys.getInodeCaches resolvedks
forM_ (M.toList unstagedmap) $ \(i, f) ->
whenM (matchesresolved is i f) $
- liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
+ liftIO $ removeWhenExistsWith removeFile f
where
fs = S.fromList resolvedfs
ks = S.fromList resolvedks
matchesresolved is i f
| S.member f fs || S.member (conflictCruftBase f) fs = anyM id
[ pure $ either (const False) (`S.member` is) i
- , inks <$> isAnnexLink (toRawFilePath f)
- , inks <$> liftIO (isPointerFile (toRawFilePath f))
+ , inks <$> isAnnexLink f
+ , inks <$> liftIO (isPointerFile f)
]
| otherwise = return False
-conflictCruftBase :: FilePath -> FilePath
-conflictCruftBase f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f
+conflictCruftBase :: OsPath -> OsPath
+conflictCruftBase = toOsPath
+ . reverse
+ . drop 1
+ . dropWhile (/= '~')
+ . reverse
+ . fromOsPath
{- When possible, reuse an existing file from the srcmap as the
- content of a worktree file in the resolved merge. It must have the
- same name as the origfile, or a name that git would use for conflict
- cruft. And, its inode cache must be a known one for the key. -}
-reuseOldFile :: InodeMap -> Key -> FilePath -> FilePath -> Annex Bool
+reuseOldFile :: InodeMap -> Key -> OsPath -> OsPath -> Annex Bool
reuseOldFile srcmap key origfile destfile = do
is <- map (inodeCacheToKey Strongly)
<$> Database.Keys.getInodeCaches key
, Param "git-annex automatic merge conflict fix"
]
-type InodeMap = M.Map (Either FilePath InodeCacheKey) FilePath
+type InodeMap = M.Map (Either OsPath InodeCacheKey) OsPath
-inodeMap :: Annex ([RawFilePath], IO Bool) -> Annex InodeMap
+inodeMap :: Annex ([OsPath], IO Bool) -> Annex InodeMap
inodeMap getfiles = do
(fs, cleanup) <- getfiles
fsis <- forM fs $ \f -> do
- s <- liftIO $ R.getSymbolicLinkStatus f
- let f' = fromRawFilePath f
+ s <- liftIO $ R.getSymbolicLinkStatus (fromOsPath f)
if isSymbolicLink s
- then pure $ Just (Left f', f')
+ then pure $ Just (Left f, f)
else withTSDelta (\d -> liftIO $ toInodeCache d f s)
>>= return . \case
- Just i -> Just (Right (inodeCacheToKey Strongly i), f')
+ Just i -> Just (Right (inodeCacheToKey Strongly i), f)
Nothing -> Nothing
void $ liftIO cleanup
return $ M.fromList $ catMaybes fsis
import Data.ByteString.Builder
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar
-import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (isRegularFile)
import Annex.Common
- transitions that have not been applied to all refs will be applied on
- the fly.
-}
-get :: RawFilePath -> Annex L.ByteString
+get :: OsPath -> Annex L.ByteString
get file = do
st <- update
case getCache file st of
- using some optimised method. The journal has to be checked, in case
- it has a newer version of the file that has not reached the branch yet.
-}
-precache :: RawFilePath -> L.ByteString -> Annex ()
+precache :: OsPath -> L.ByteString -> Annex ()
precache file branchcontent = do
st <- getState
content <- if journalIgnorable st
- reflect changes in remotes.
- (Changing the value this returns, and then merging is always the
- same as using get, and then changing its value.) -}
-getLocal :: RawFilePath -> Annex L.ByteString
+getLocal :: OsPath -> Annex L.ByteString
getLocal = getLocal' (GetPrivate True)
-getLocal' :: GetPrivate -> RawFilePath -> Annex L.ByteString
+getLocal' :: GetPrivate -> OsPath -> Annex L.ByteString
getLocal' getprivate file = do
- fastDebug "Annex.Branch" ("read " ++ fromRawFilePath file)
+ fastDebug "Annex.Branch" ("read " ++ fromOsPath file)
go =<< getJournalFileStale getprivate file
where
go NoJournalledContent = getRef fullname file
return (v <> journalcontent)
{- Gets the content of a file as staged in the branch's index. -}
-getStaged :: RawFilePath -> Annex L.ByteString
+getStaged :: OsPath -> Annex L.ByteString
getStaged = getRef indexref
where
-- This makes git cat-file be run with ":file",
-- so it looks at the index.
indexref = Ref ""
-getHistorical :: RefDate -> RawFilePath -> Annex L.ByteString
+getHistorical :: RefDate -> OsPath -> Annex L.ByteString
getHistorical date file =
-- This check avoids some ugly error messages when the reflog
-- is empty.
, getRef (Git.Ref.dateRef fullname date) file
)
-getRef :: Ref -> RawFilePath -> Annex L.ByteString
+getRef :: Ref -> OsPath -> Annex L.ByteString
getRef ref file = withIndex $ catFile ref file
{- Applies a function to modify the content of a file.
- Note that this does not cause the branch to be merged, it only
- modifies the current content of the file on the branch.
-}
-change :: Journalable content => RegardingUUID -> RawFilePath -> (L.ByteString -> content) -> Annex ()
+change :: Journalable content => RegardingUUID -> OsPath -> (L.ByteString -> content) -> Annex ()
change ru file f = lockJournal $ \jl -> f <$> getToChange ru file >>= set jl ru file
{- Applies a function which can modify the content of a file, or not.
- When the file was modified, runs the onchange action, and returns
- True. The action is run while the journal is still locked,
- so another concurrent call to this cannot happen while it is running. -}
-maybeChange :: Journalable content => RegardingUUID -> RawFilePath -> (L.ByteString -> Maybe content) -> Annex () -> Annex Bool
+maybeChange :: Journalable content => RegardingUUID -> OsPath -> (L.ByteString -> Maybe content) -> Annex () -> Annex Bool
maybeChange ru file f onchange = lockJournal $ \jl -> do
v <- getToChange ru file
case f v of
- state that would confuse the older version. This is planned to be
- changed in a future repository version.
-}
-changeOrAppend :: Journalable content => RegardingUUID -> RawFilePath -> (L.ByteString -> ChangeOrAppend content) -> Annex ()
+changeOrAppend :: Journalable content => RegardingUUID -> OsPath -> (L.ByteString -> ChangeOrAppend content) -> Annex ()
changeOrAppend ru file f = lockJournal $ \jl ->
checkCanAppendJournalFile jl ru file >>= \case
Just appendable -> ifM (annexAlwaysCompact <$> Annex.getGitConfig)
oldc <> journalableByteString toappend
{- Only get private information when the RegardingUUID is itself private. -}
-getToChange :: RegardingUUID -> RawFilePath -> Annex L.ByteString
+getToChange :: RegardingUUID -> OsPath -> Annex L.ByteString
getToChange ru f = flip getLocal' f . GetPrivate =<< regardingPrivateUUID ru
{- Records new content of a file into the journal.
- git-annex index, and should not be written to the public git-annex
- branch.
-}
-set :: Journalable content => JournalLocked -> RegardingUUID -> RawFilePath -> content -> Annex ()
+set :: Journalable content => JournalLocked -> RegardingUUID -> OsPath -> content -> Annex ()
set jl ru f c = do
journalChanged
setJournalFile jl ru f c
- fastDebug "Annex.Branch" ("set " ++ fromRawFilePath f)
+ fastDebug "Annex.Branch" ("set " ++ fromOsPath f)
-- Could cache the new content, but it would involve
-- evaluating a Journalable Builder twice, which is not very
-- efficient. Instead, assume that it's not common to need to read
invalidateCache f
{- Appends content to the journal file. -}
-append :: Journalable content => JournalLocked -> RawFilePath -> AppendableJournalFile -> content -> Annex ()
+append :: Journalable content => JournalLocked -> OsPath -> AppendableJournalFile -> content -> Annex ()
append jl f appendable toappend = do
journalChanged
appendJournalFile jl appendable toappend
- fastDebug "Annex.Branch" ("append " ++ fromRawFilePath f)
+ fastDebug "Annex.Branch" ("append " ++ fromOsPath f)
invalidateCache f
{- Commit message used when making a commit of whatever data has changed
- not been merged in, returns Nothing, because it's not possible to
- efficiently handle that.
-}
-files :: Annex (Maybe ([RawFilePath], IO Bool))
+files :: Annex (Maybe ([OsPath], IO Bool))
files = do
st <- update
if not (null (unmergedRefs st))
{- Lists all files currently in the journal, but not files in the private
- journal. -}
-journalledFiles :: Annex [RawFilePath]
+journalledFiles :: Annex [OsPath]
journalledFiles = getJournalledFilesStale gitAnnexJournalDir
-journalledFilesPrivate :: Annex [RawFilePath]
+journalledFilesPrivate :: Annex [OsPath]
journalledFilesPrivate = ifM privateUUIDsKnown
( getJournalledFilesStale gitAnnexPrivateJournalDir
, return []
{- Files in the branch, not including any from journalled changes,
- and without updating the branch. -}
-branchFiles :: Annex ([RawFilePath], IO Bool)
+branchFiles :: Annex ([OsPath], IO Bool)
branchFiles = withIndex $ inRepo branchFiles'
-branchFiles' :: Git.Repo -> IO ([RawFilePath], IO Bool)
-branchFiles' = Git.Command.pipeNullSplit' $
+branchFiles' :: Git.Repo -> IO ([OsPath], IO Bool)
+branchFiles' = Git.Command.pipeNullSplit'' toOsPath $
lsTreeParams Git.LsTree.LsTreeRecursive (Git.LsTree.LsTreeLong False)
fullname
[Param "--name-only"]
prepareModifyIndex :: JournalLocked -> Annex ()
prepareModifyIndex _jl = do
index <- fromRepo gitAnnexIndex
- void $ liftIO $ tryIO $ R.removeLink (index <> ".lock")
+ void $ liftIO $ tryIO $
+ removeFile (index <> literalOsPath ".lock")
{- Runs an action using the branch's index file. -}
withIndex :: Annex a -> Annex a
withIndex' bootstrapping a = withIndexFile AnnexIndexFile $ \f -> do
checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do
unless bootstrapping create
- createAnnexDirectory $ toRawFilePath $ takeDirectory f
+ createAnnexDirectory $ takeDirectory f
unless bootstrapping $ inRepo genIndex
a
{- Checks if the index needs to be updated. -}
needUpdateIndex :: Git.Ref -> Annex Bool
needUpdateIndex branchref = do
- f <- toOsPath <$> fromRepo gitAnnexIndexStatus
+ f <- fromRepo gitAnnexIndexStatus
committedref <- Git.Ref . firstLine' <$>
liftIO (catchDefaultIO mempty $ F.readFile' f)
return (committedref /= branchref)
Git.UpdateIndex.streamUpdateIndex g
[genstream dir h jh jlogh]
commitindex
- liftIO $ cleanup (fromRawFilePath dir) jlogh jlogf
+ liftIO $ cleanup dir jlogh jlogf
where
genstream dir h jh jlogh streamer = readDirectory jh >>= \case
Nothing -> return ()
Just file -> do
- let path = dir P.</> file
- unless (dirCruft file) $ whenM (isfile path) $ do
+ let file' = toOsPath file
+ let path = dir </> file'
+ unless (file' `elem` dirCruft) $ whenM (isfile path) $ do
sha <- Git.HashObject.hashFile h path
B.hPutStr jlogh (file <> "\n")
streamer $ Git.UpdateIndex.updateIndexLine
- sha TreeFile (asTopFilePath $ fileJournal file)
+ sha TreeFile (asTopFilePath $ fileJournal file')
genstream dir h jh jlogh streamer
- isfile file = isRegularFile <$> R.getFileStatus file
+ isfile file = isRegularFile <$> R.getFileStatus (fromOsPath file)
-- Clean up the staged files, as listed in the temp log file.
-- The temp file is used to avoid needing to buffer all the
-- filenames in memory.
hFlush jlogh
hSeek jlogh AbsoluteSeek 0
stagedfs <- lines <$> hGetContents jlogh
- mapM_ (removeFile . (dir </>)) stagedfs
+ mapM_ (removeFile . (dir </>) . toOsPath) stagedfs
hClose jlogh
- removeWhenExistsWith (R.removeLink) (fromOsPath jlogf)
- openjlog tmpdir = liftIO $ openTmpFileIn (toOsPath tmpdir) (toOsPath "jlog")
+ removeWhenExistsWith removeFile jlogf
+ openjlog tmpdir = liftIO $ openTmpFileIn tmpdir (literalOsPath "jlog")
getLocalTransitions :: Annex Transitions
getLocalTransitions =
S.fromList . mapMaybe Git.Sha.extractSha . fileLines' <$> content
where
content = do
- f <- toOsPath <$> fromRepo gitAnnexIgnoredRefs
+ f <- fromRepo gitAnnexIgnoredRefs
liftIO $ catchDefaultIO mempty $ F.readFile' f
addMergedRefs :: [(Git.Sha, Git.Branch)] -> Annex ()
getMergedRefs' :: Annex [(Git.Sha, Git.Branch)]
getMergedRefs' = do
- f <- toOsPath <$> fromRepo gitAnnexMergedRefs
+ f <- fromRepo gitAnnexMergedRefs
s <- liftIO $ catchDefaultIO mempty $ F.readFile' f
return $ map parse $ fileLines' s
where
= UnmergedBranches t
| NoUnmergedBranches t
-type FileContents t b = Maybe (t, RawFilePath, Maybe (L.ByteString, Maybe b))
+type FileContents t b = Maybe (t, OsPath, Maybe (L.ByteString, Maybe b))
{- Runs an action on the content of selected files from the branch.
- This is much faster than reading the content of each file in turn,
-- the callback can be run more than once on the same filename,
-- and in this case it's also possible for the callback to be
-- passed some of the same file content repeatedly.
- -> (RawFilePath -> Maybe v)
+ -> (OsPath -> Maybe v)
-> (Annex (FileContents v Bool) -> Annex a)
-> Annex (UnmergedBranches (a, Git.Sha))
overBranchFileContents ignorejournal select go = do
else NoUnmergedBranches v
overBranchFileContents'
- :: (RawFilePath -> Maybe v)
+ :: (OsPath -> Maybe v)
-> (Annex (FileContents v Bool) -> Annex a)
-> BranchState
-> Annex (a, Git.Sha)
- files.
-}
overJournalFileContents
- :: (RawFilePath -> L.ByteString -> Annex (L.ByteString, Maybe b))
+ :: (OsPath -> L.ByteString -> Annex (L.ByteString, Maybe b))
-- ^ Called with the journalled file content when the journalled
-- content may be stale or lack information committed to the
-- git-annex branch.
- -> (RawFilePath -> Maybe v)
+ -> (OsPath -> Maybe v)
-> (Annex (FileContents v b) -> Annex a)
-> Annex a
overJournalFileContents handlestale select go = do
go $ overJournalFileContents' buf handlestale select
overJournalFileContents'
- :: MVar ([RawFilePath], [RawFilePath])
- -> (RawFilePath -> L.ByteString -> Annex (L.ByteString, Maybe b))
- -> (RawFilePath -> Maybe a)
+ :: MVar ([OsPath], [OsPath])
+ -> (OsPath -> L.ByteString -> Annex (L.ByteString, Maybe b))
+ -> (OsPath -> Maybe a)
-> Annex (FileContents a b)
overJournalFileContents' buf handlestale select =
liftIO (tryTakeMVar buf) >>= \case
, journalIgnorable = False
}
-setCache :: RawFilePath -> L.ByteString -> Annex ()
+setCache :: OsPath -> L.ByteString -> Annex ()
setCache file content = changeState $ \s -> s
{ cachedFileContents = add (cachedFileContents s) }
where
| length l < logFilesToCache = (file, content) : l
| otherwise = (file, content) : Prelude.init l
-getCache :: RawFilePath -> BranchState -> Maybe L.ByteString
+getCache :: OsPath -> BranchState -> Maybe L.ByteString
getCache file state = go (cachedFileContents state)
where
go [] = Nothing
| f == file && not (needInteractiveAccess state) = Just c
| otherwise = go rest
-invalidateCache :: RawFilePath -> Annex ()
+invalidateCache :: OsPath -> Annex ()
invalidateCache f = changeState $ \s -> s
{ cachedFileContents = filter (\(f', _) -> f' /= f)
(cachedFileContents s)
import Types.CatFileHandles
import Utility.ResourcePool
-catFile :: Git.Branch -> RawFilePath -> Annex L.ByteString
+catFile :: Git.Branch -> OsPath -> Annex L.ByteString
catFile branch file = withCatFileHandle $ \h ->
liftIO $ Git.CatFile.catFile h branch file
-catFileDetails :: Git.Branch -> RawFilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType))
+catFileDetails :: Git.Branch -> OsPath -> Annex (Maybe (L.ByteString, Sha, ObjectType))
catFileDetails branch file = withCatFileHandle $ \h ->
liftIO $ Git.CatFile.catFileDetails h branch file
catKey' _ _ = return Nothing
{- Gets a symlink target. -}
-catSymLinkTarget :: Sha -> Annex RawFilePath
-catSymLinkTarget sha = fromInternalGitPath . L.toStrict <$> get
+catSymLinkTarget :: Sha -> Annex OsPath
+catSymLinkTarget sha = fromInternalGitPath . toOsPath . L.toStrict <$> get
where
-- Avoid buffering the whole file content, which might be large.
-- 8192 is enough if it really is a symlink.
-
- So, this gets info from the index, unless running as a daemon.
-}
-catKeyFile :: RawFilePath -> Annex (Maybe Key)
+catKeyFile :: OsPath -> Annex (Maybe Key)
catKeyFile f = ifM (Annex.getState Annex.daemon)
( catKeyFileHEAD f
, maybe (pure Nothing) catKey =<< inRepo (Git.Ref.fileRef f)
)
-catKeyFileHEAD :: RawFilePath -> Annex (Maybe Key)
+catKeyFileHEAD :: OsPath -> Annex (Maybe Key)
catKeyFileHEAD f = maybe (pure Nothing) catKey
=<< inRepo (Git.Ref.fileFromRef Git.Ref.headRef f)
{- Look in the original branch from whence an adjusted branch is based
- to find the file. But only when the adjustment hides some files. -}
-catKeyFileHidden :: RawFilePath -> CurrBranch -> Annex (Maybe Key)
+catKeyFileHidden :: OsPath -> CurrBranch -> Annex (Maybe Key)
catKeyFileHidden = hiddenCat catKey
-catObjectMetaDataHidden :: RawFilePath -> CurrBranch -> Annex (Maybe (Sha, Integer, ObjectType))
+catObjectMetaDataHidden :: OsPath -> CurrBranch -> Annex (Maybe (Sha, Integer, ObjectType))
catObjectMetaDataHidden = hiddenCat catObjectMetaData
-hiddenCat :: (Ref -> Annex (Maybe a)) -> RawFilePath -> CurrBranch -> Annex (Maybe a)
+hiddenCat :: (Ref -> Annex (Maybe a)) -> OsPath -> CurrBranch -> Annex (Maybe a)
hiddenCat a f (Just origbranch, Just adj)
| adjustmentHidesFiles adj =
maybe (pure Nothing) a
import Git.Sha
import qualified Utility.SimpleProtocol as Proto
import qualified Utility.FileIO as F
+import qualified Utility.OsString as OS
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TBMChan
-import qualified System.FilePath.ByteString as P
newtype ChangedRefs = ChangedRefs [Git.Ref]
deriving (Show)
g <- gitRepo
let gittop = Git.localGitDir g
- let refdir = gittop P.</> "refs"
+ let refdir = gittop </> literalOsPath "refs"
liftIO $ createDirectoryUnder [gittop] refdir
let notifyhook = Just $ notifyHook chan
if canWatch
then do
- h <- liftIO $ watchDir
- (fromRawFilePath refdir)
+ h <- liftIO $ watchDir refdir
(const False) True hooks id
return $ Just $ ChangedRefsHandle h chan
else return Nothing
-notifyHook :: TBMChan Git.Sha -> FilePath -> Maybe FileStatus -> IO ()
+notifyHook :: TBMChan Git.Sha -> OsPath -> Maybe FileStatus -> IO ()
notifyHook chan reffile _
- | ".lock" `isSuffixOf` reffile = noop
+ | literalOsPath ".lock" `OS.isSuffixOf` reffile = noop
| otherwise = void $ do
sha <- catchDefaultIO Nothing $
- extractSha <$> F.readFile' (toOsPath (toRawFilePath reffile))
+ extractSha <$> F.readFile' reffile
-- When the channel is full, there is probably no reader
-- running, or ref changes have been occurring very fast,
-- so it's ok to not write the change to it.
, "annex.mincopies"
]
-checkAttr :: Git.Attr -> RawFilePath -> Annex String
+checkAttr :: Git.Attr -> OsPath -> Annex String
checkAttr attr file = withCheckAttrHandle $ \h -> do
r <- liftIO $ Git.checkAttr h attr file
if r == Git.unspecifiedAttr
then return ""
else return r
-checkAttrs :: [Git.Attr] -> RawFilePath -> Annex [String]
+checkAttrs :: [Git.Attr] -> OsPath -> Annex [String]
checkAttrs attrs file = withCheckAttrHandle $ \h ->
liftIO $ Git.checkAttrs h attrs file
newtype CheckGitIgnore = CheckGitIgnore Bool
-checkIgnored :: CheckGitIgnore -> RawFilePath -> Annex Bool
+checkIgnored :: CheckGitIgnore -> OsPath -> Annex Bool
checkIgnored (CheckGitIgnore False) _ = pure False
checkIgnored (CheckGitIgnore True) file =
ifM (Annex.getRead Annex.force)
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
-import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (isSymbolicLink, linkCount)
import Data.Time.Clock.POSIX
{- Passed the object content file, and maybe a separate lock file to use,
- when the content file itself should not be locked. -}
type ContentLocker
- = RawFilePath
+ = OsPath
-> Maybe LockFile
->
( Annex (Maybe LockHandle)
-- and prior to deleting the lock file, in order to
-- ensure that no other processes also have a shared lock.
#else
- , Maybe (RawFilePath -> Annex ())
+ , Maybe (OsPath -> Annex ())
-- ^ On Windows, this is called after the lock is dropped,
-- but before the lock file is cleaned up.
#endif
let lck = do
modifyContentDir lockfile $
void $ liftIO $ tryIO $
- writeFile (fromRawFilePath lockfile) ""
+ writeFile (fromOsPath lockfile) ""
liftIO $ takelock lockfile
in (lck, Nothing)
-- never reached; windows always uses a separate lock file
cleanuplockfile lockfile = void $ tryNonAsync $ do
thawContentDir lockfile
- liftIO $ removeWhenExistsWith R.removeLink lockfile
+ liftIO $ removeWhenExistsWith removeFile lockfile
cleanObjectDirs lockfile
{- Runs an action, passing it the temp file to get,
- and if the action succeeds, verifies the file matches
- the key and moves the file into the annex as a key's content. -}
-getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> Maybe FileSize -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool
+getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> Maybe FileSize -> (OsPath -> Annex (Bool, Verification)) -> Annex Bool
getViaTmp rsp v key af sz action =
checkDiskSpaceToGet key sz False $
getViaTmpFromDisk rsp v key af action
{- Like getViaTmp, but does not check that there is enough disk space
- for the incoming key. For use when the key content is already on disk
- and not being copied into place. -}
-getViaTmpFromDisk :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool
+getViaTmpFromDisk :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> (OsPath -> Annex (Bool, Verification)) -> Annex Bool
getViaTmpFromDisk rsp v key af action = checkallowed $ do
tmpfile <- prepTmp key
- resuming <- liftIO $ R.doesPathExist tmpfile
+ resuming <- liftIO $ R.doesPathExist $ fromOsPath tmpfile
(ok, verification) <- action tmpfile
-- When the temp file already had content, we don't know if
-- that content is good or not, so only trust if it the action
- left off, and so if the bad content were not deleted, repeated downloads
- would continue to fail.
-}
-verificationOfContentFailed :: RawFilePath -> Annex ()
+verificationOfContentFailed :: OsPath -> Annex ()
verificationOfContentFailed tmpfile = do
warning "Verification of content failed"
pruneTmpWorkDirBefore tmpfile
- (liftIO . removeWhenExistsWith R.removeLink)
+ (liftIO . removeWhenExistsWith removeFile)
{- Checks if there is enough free disk space to download a key
- to its temp file.
checkDiskSpaceToGet :: Key -> Maybe FileSize -> a -> Annex a -> Annex a
checkDiskSpaceToGet key sz unabletoget getkey = do
tmp <- fromRepo (gitAnnexTmpObjectLocation key)
- e <- liftIO $ doesFileExist (fromRawFilePath tmp)
+ e <- liftIO $ doesFileExist tmp
alreadythere <- liftIO $ if e
then getFileSize tmp
else return 0
, return unabletoget
)
-prepTmp :: Key -> Annex RawFilePath
+prepTmp :: Key -> Annex OsPath
prepTmp key = do
tmp <- fromRepo $ gitAnnexTmpObjectLocation key
createAnnexDirectory (parentDir tmp)
- the temp file. If the action throws an exception, the temp file is
- left behind, which allows for resuming.
-}
-withTmp :: Key -> (RawFilePath -> Annex a) -> Annex a
+withTmp :: Key -> (OsPath -> Annex a) -> Annex a
withTmp key action = do
tmp <- prepTmp key
res <- action tmp
- pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)
+ pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith removeFile)
return res
{- Moves a key's content into .git/annex/objects/
- accepted into the repository. Will display a warning message in this
- case. May also throw exceptions in some cases.
-}
-moveAnnex :: Key -> AssociatedFile -> RawFilePath -> Annex Bool
+moveAnnex :: Key -> AssociatedFile -> OsPath -> Annex Bool
moveAnnex key af src = ifM (checkSecureHashes' key)
( do
#ifdef mingw32_HOST_OS
, return False
)
where
- storeobject dest = ifM (liftIO $ R.doesPathExist dest)
+ storeobject dest = ifM (liftIO $ R.doesPathExist $ fromOsPath dest)
( alreadyhave
, adjustedBranchRefresh af $ modifyContentDir dest $ do
liftIO $ moveFile src dest
Database.Keys.addInodeCaches key
(catMaybes (destic:ics))
)
- alreadyhave = liftIO $ R.removeLink src
+ alreadyhave = liftIO $ removeFile src
checkSecureHashes :: Key -> Annex (Maybe String)
checkSecureHashes key = ifM (Backend.isCryptographicallySecureKey key)
{- Populates the annex object file by hard linking or copying a source
- file to it. -}
-linkToAnnex :: Key -> RawFilePath -> Maybe InodeCache -> Annex LinkAnnexResult
+linkToAnnex :: Key -> OsPath -> Maybe InodeCache -> Annex LinkAnnexResult
linkToAnnex key src srcic = ifM (checkSecureHashes' key)
( do
dest <- calcRepo (gitAnnexLocation key)
- afterwards. Note that a consequence of this is that, if the file
- already exists, it will be overwritten.
-}
-linkFromAnnex :: Key -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult
+linkFromAnnex :: Key -> OsPath -> Maybe FileMode -> Annex LinkAnnexResult
linkFromAnnex key dest destmode =
replaceFile' (const noop) dest (== LinkAnnexOk) $ \tmp ->
linkFromAnnex' key tmp destmode
{- This is only safe to use when dest is not a worktree file. -}
-linkFromAnnex' :: Key -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult
+linkFromAnnex' :: Key -> OsPath -> Maybe FileMode -> Annex LinkAnnexResult
linkFromAnnex' key dest destmode = do
src <- calcRepo (gitAnnexLocation key)
srcic <- withTSDelta (liftIO . genInodeCache src)
-
- Nothing is done if the destination file already exists.
-}
-linkAnnex :: FromTo -> Key -> RawFilePath -> Maybe InodeCache -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult
+linkAnnex :: FromTo -> Key -> OsPath -> Maybe InodeCache -> OsPath -> Maybe FileMode -> Annex LinkAnnexResult
linkAnnex _ _ _ Nothing _ _ = return LinkAnnexFailed
linkAnnex fromto key src (Just srcic) dest destmode =
withTSDelta (liftIO . genInodeCache dest) >>= \case
catMaybes [destic, Just srcic]
return LinkAnnexOk
_ -> do
- liftIO $ removeWhenExistsWith R.removeLink dest
+ liftIO $ removeWhenExistsWith removeFile dest
failed
{- Removes the annex object file for a key. Lowlevel. -}
obj <- calcRepo (gitAnnexLocation key)
modifyContentDir obj $ do
secureErase obj
- liftIO $ removeWhenExistsWith R.removeLink obj
+ liftIO $ removeWhenExistsWith removeFile obj
{- Runs an action to transfer an object's content. The action is also
- passed the size of the object.
- If this happens, runs the rollback action and throws an exception.
- The rollback action should remove the data that was transferred.
-}
-sendAnnex :: Key -> Maybe FilePath -> Annex () -> (FilePath -> FileSize -> Annex a) -> Annex a
+sendAnnex :: Key -> Maybe OsPath -> Annex () -> (OsPath -> FileSize -> Annex a) -> Annex a
sendAnnex key o rollback sendobject = go =<< prepSendAnnex' key o
where
go (Just (f, sz, check)) = do
- Annex monad of the remote that is receiving the object, rather than
- the sender. So it cannot rely on Annex state.
-}
-prepSendAnnex :: Key -> Maybe FilePath -> Annex (Maybe (FilePath, FileSize, Annex Bool))
+prepSendAnnex :: Key -> Maybe OsPath -> Annex (Maybe (OsPath, FileSize, Annex Bool))
prepSendAnnex key Nothing = withObjectLoc key $ \f -> do
let retval c cs = return $ Just
- ( fromRawFilePath f
+ ( f
, inodeCacheFileSize c
, sameInodeCache f cs
)
Nothing -> return Nothing
-- If the provided object file is the annex object file, handle as above.
prepSendAnnex key (Just o) = withObjectLoc key $ \aof ->
- let o' = toRawFilePath o
- in if aof == o'
+ if aof == o
then prepSendAnnex key Nothing
else do
- withTSDelta (liftIO . genInodeCache o') >>= \case
+ withTSDelta (liftIO . genInodeCache o) >>= \case
Nothing -> return Nothing
Just c -> return $ Just
( o
, inodeCacheFileSize c
- , sameInodeCache o' [c]
+ , sameInodeCache o [c]
)
-prepSendAnnex' :: Key -> Maybe FilePath -> Annex (Maybe (FilePath, FileSize, Annex (Maybe String)))
+prepSendAnnex' :: Key -> Maybe OsPath -> Annex (Maybe (OsPath, FileSize, Annex (Maybe String)))
prepSendAnnex' key o = prepSendAnnex key o >>= \case
Just (f, sz, checksuccess) ->
let checksuccess' = ifM checksuccess
-
- Does nothing if the object directory is not empty, and does not
- throw an exception if it's unable to remove a directory. -}
-cleanObjectDirs :: RawFilePath -> Annex ()
+cleanObjectDirs :: OsPath -> Annex ()
cleanObjectDirs f = do
HashLevels n <- objectHashLevels <$> Annex.getGitConfig
liftIO $ go f (succ n)
let dir = parentDir file
maybe noop (const $ go dir (n-1))
<=< catchMaybeIO $ tryWhenExists $
- removeDirectory (fromRawFilePath dir)
+ removeDirectory dir
{- Removes a key's file from .git/annex/objects/ -}
removeAnnex :: ContentRemovalLock -> Annex ()
removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file ->
cleanObjectLoc key $ do
secureErase file
- liftIO $ removeWhenExistsWith R.removeLink file
+ liftIO $ removeWhenExistsWith removeFile file
g <- Annex.gitRepo
mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g)
=<< Database.Keys.getAssociatedFiles key
where
-- Check associated pointer file for modifications, and reset if
-- it's unmodified.
- resetpointer file = unlessM (liftIO $ isSymbolicLink <$> R.getSymbolicLinkStatus file) $
+ resetpointer file = unlessM (liftIO $ isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath file)) $
ifM (isUnmodified key file)
( adjustedBranchRefresh (AssociatedFile (Just file)) $
depopulatePointerFile key file
{- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
- returns the file it was moved to. -}
-moveBad :: Key -> Annex RawFilePath
+moveBad :: Key -> Annex OsPath
moveBad key = do
src <- calcRepo (gitAnnexLocation key)
bad <- fromRepo gitAnnexBadDir
- let dest = bad P.</> P.takeFileName src
+ let dest = bad </> takeFileName src
createAnnexDirectory (parentDir dest)
cleanObjectLoc key $
liftIO $ moveFile src dest
then do
contents' <- filterM present contents
keys <- filterM (Annex.eval s . want) $
- mapMaybe (fileKey . P.takeFileName) contents'
+ mapMaybe (fileKey . takeFileName) contents'
continue keys []
else do
let deeper = walk s (depth - 1)
present _ | inanywhere = pure True
present d = presentInAnnex d
- presentInAnnex = R.doesPathExist . contentfile
- contentfile d = d P.</> P.takeFileName d
+ presentInAnnex = R.doesPathExist . fromOsPath . contentfile
+ contentfile d = d </> takeFileName d
{- Things to do to record changes to content when shutting down.
-
- Otherwise, only displays one error message, from one of the urls
- that failed.
-}
-downloadUrl :: Bool -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> [Url.URLString] -> FilePath -> Url.UrlOptions -> Annex Bool
+downloadUrl :: Bool -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> [Url.URLString] -> OsPath -> Url.UrlOptions -> Annex Bool
downloadUrl listfailedurls k p iv urls file uo =
-- Poll the file to handle configurations where an external
-- download command is used.
- meteredFile (toRawFilePath file) (Just p) k (go urls [])
+ meteredFile file (Just p) k (go urls [])
where
go (u:us) errs p' = Url.download' p' iv u file uo >>= \case
Right () -> return True
{- Copies a key's content, when present, to a temp file.
- This is used to speed up some rsyncs. -}
-preseedTmp :: Key -> FilePath -> Annex Bool
+preseedTmp :: Key -> OsPath -> Annex Bool
preseedTmp key file = go =<< inAnnex key
where
go False = return False
go True = do
ok <- copy
- when ok $ thawContent (toRawFilePath file)
+ when ok $ thawContent file
return ok
copy = ifM (liftIO $ doesFileExist file)
( return True
, do
- s <- fromRawFilePath <$> (calcRepo $ gitAnnexLocation key)
+ s <- calcRepo $ gitAnnexLocation key
liftIO $ ifM (doesFileExist s)
( copyFileExternal CopyTimeStamps s file
, return False
{- Finds files directly inside a directory like gitAnnexBadDir
- (not in subdirectories) and returns the corresponding keys. -}
-dirKeys :: (Git.Repo -> RawFilePath) -> Annex [Key]
+dirKeys :: (Git.Repo -> OsPath) -> Annex [Key]
dirKeys dirspec = do
- dir <- fromRawFilePath <$> fromRepo dirspec
+ dir <- fromRepo dirspec
ifM (liftIO $ doesDirectoryExist dir)
( do
contents <- liftIO $ getDirectoryContents dir
files <- liftIO $ filterM doesFileExist $
map (dir </>) contents
- return $ mapMaybe (fileKey . P.takeFileName . toRawFilePath) files
+ return $ mapMaybe (fileKey . takeFileName) files
, return []
)
- Also, stale keys that can be proven to have no value
- (ie, their content is already present) are deleted.
-}
-staleKeysPrune :: (Git.Repo -> RawFilePath) -> Bool -> Annex [Key]
+staleKeysPrune :: (Git.Repo -> OsPath) -> Bool -> Annex [Key]
staleKeysPrune dirspec nottransferred = do
contents <- dirKeys dirspec
dir <- fromRepo dirspec
forM_ dups $ \k ->
- pruneTmpWorkDirBefore (dir P.</> keyFile k)
- (liftIO . R.removeLink)
+ pruneTmpWorkDirBefore (dir </> keyFile k)
+ (liftIO . removeFile)
if nottransferred
then do
- This preserves the invariant that the workdir never exists without
- the content file.
-}
-pruneTmpWorkDirBefore :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
+pruneTmpWorkDirBefore :: OsPath -> (OsPath -> Annex a) -> Annex a
pruneTmpWorkDirBefore f action = do
- let workdir = fromRawFilePath $ gitAnnexTmpWorkDir f
+ let workdir = gitAnnexTmpWorkDir f
liftIO $ whenM (doesDirectoryExist workdir) $
removeDirectoryRecursive workdir
action f
- the temporary work directory is retained (unless
- empty), so anything in it can be used on resume.
-}
-withTmpWorkDir :: Key -> (RawFilePath -> Annex (Maybe a)) -> Annex (Maybe a)
+withTmpWorkDir :: Key -> (OsPath -> Annex (Maybe a)) -> Annex (Maybe a)
withTmpWorkDir key action = do
-- Create the object file if it does not exist. This way,
-- staleKeysPrune only has to look for object files, and can
-- clean up gitAnnexTmpWorkDir for those it finds.
obj <- prepTmp key
- let obj' = fromRawFilePath obj
- unlessM (liftIO $ doesFileExist obj') $ do
- liftIO $ writeFile obj' ""
+ unlessM (liftIO $ doesFileExist obj) $ do
+ liftIO $ writeFile (fromOsPath obj) ""
setAnnexFilePerm obj
let tmpdir = gitAnnexTmpWorkDir obj
createAnnexDirectory tmpdir
res <- action tmpdir
case res of
- Just _ -> liftIO $ removeDirectoryRecursive (fromRawFilePath tmpdir)
- Nothing -> liftIO $ void $ tryIO $ removeDirectory (fromRawFilePath tmpdir)
+ Just _ -> liftIO $ removeDirectoryRecursive tmpdir
+ Nothing -> liftIO $ void $ tryIO $ removeDirectory tmpdir
return res
{- Finds items in the first, smaller list, that are not
getKeyStatus key = catchDefaultIO KeyMissing $ do
afs <- not . null <$> Database.Keys.getAssociatedFiles key
obj <- calcRepo (gitAnnexLocation key)
- multilink <- ((> 1) . linkCount <$> liftIO (R.getFileStatus obj))
+ multilink <- ((> 1) . linkCount <$> liftIO (R.getFileStatus (fromOsPath obj)))
return $ if multilink && afs
then KeyUnlockedThin
else KeyPresent
-getKeyFileStatus :: Key -> RawFilePath -> Annex KeyStatus
+getKeyFileStatus :: Key -> OsPath -> Annex KeyStatus
getKeyFileStatus key file = do
s <- getKeyStatus key
case s of
- timestamp. The file is written atomically, so when it contained an
- earlier timestamp, a reader will always see one or the other timestamp.
-}
-writeContentRetentionTimestamp :: Key -> RawFilePath -> POSIXTime -> Annex ()
+writeContentRetentionTimestamp :: Key -> OsPath -> POSIXTime -> Annex ()
writeContentRetentionTimestamp key rt t = do
lckfile <- calcRepo (gitAnnexContentRetentionTimestampLock key)
modifyContentDirWhenExists lckfile $ bracket (lock lckfile) unlock $ \_ ->
readContentRetentionTimestamp rt >>= \case
Just ts | ts >= t -> return ()
_ -> replaceFile (const noop) rt $ \tmp ->
- liftIO $ writeFile (fromRawFilePath tmp) $ show t
+ liftIO $ writeFile (fromOsPath tmp) $ show t
where
lock = takeExclusiveLock
unlock = liftIO . dropLock
{- Does not need locking because the file is written atomically. -}
-readContentRetentionTimestamp :: RawFilePath -> Annex (Maybe POSIXTime)
+readContentRetentionTimestamp :: OsPath -> Annex (Maybe POSIXTime)
readContentRetentionTimestamp rt =
- liftIO $ join <$> tryWhenExists
- (parsePOSIXTime <$> F.readFile' (toOsPath rt))
+ liftIO $ join <$> tryWhenExists (parsePOSIXTime <$> F.readFile' rt)
{- Checks if the retention timestamp is in the future, if so returns
- Nothing.
{- Remove the retention timestamp and its lock file. Another lock must
- be held, that prevents anything else writing to the file at the same
- time. -}
-removeRetentionTimeStamp :: Key -> RawFilePath -> Annex ()
+removeRetentionTimeStamp :: Key -> OsPath -> Annex ()
removeRetentionTimeStamp key rt = modifyContentDirWhenExists rt $ do
- liftIO $ removeWhenExistsWith R.removeLink rt
+ liftIO $ removeWhenExistsWith removeFile rt
rtl <- calcRepo (gitAnnexContentRetentionTimestampLock key)
- liftIO $ removeWhenExistsWith R.removeLink rtl
+ liftIO $ removeWhenExistsWith removeFile rtl
import Utility.CopyFile
import qualified Utility.RawFilePath as R
-import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (linkCount)
{- Runs the secure erase command if set, otherwise does nothing.
- File may or may not be deleted at the end; caller is responsible for
- making sure it's deleted. -}
-secureErase :: RawFilePath -> Annex ()
+secureErase :: OsPath -> Annex ()
secureErase = void . runAnnexPathHook "%file"
secureEraseAnnexHook annexSecureEraseCommand
- execute bit will be set. The mode is not fully copied over because
- git doesn't support file modes beyond execute.
-}
-linkOrCopy :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied)
+linkOrCopy :: Key -> OsPath -> OsPath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied)
linkOrCopy = linkOrCopy' (annexThin <$> Annex.getGitConfig)
-linkOrCopy' :: Annex Bool -> Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied)
+linkOrCopy' :: Annex Bool -> Key -> OsPath -> OsPath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied)
linkOrCopy' canhardlink key src dest destmode = catchDefaultIO Nothing $
ifM canhardlink
- ( hardlink
+ ( hardlinkorcopy
, copy =<< getstat
)
where
- hardlink = do
+ hardlinkorcopy = do
s <- getstat
if linkCount s > 1
then copy s
- else liftIO (R.createLink src dest >> preserveGitMode dest destmode >> return (Just Linked))
- `catchIO` const (copy s)
+ else hardlink `catchIO` const (copy s)
+ hardlink = liftIO $ do
+ R.createLink (fromOsPath src) (fromOsPath dest)
+ void $ preserveGitMode dest destmode
+ return (Just Linked)
copy s = ifM (checkedCopyFile' key src dest destmode s)
( return (Just Copied)
, return Nothing
)
- getstat = liftIO $ R.getFileStatus src
+ getstat = liftIO $ R.getFileStatus (fromOsPath src)
{- Checks disk space before copying. -}
-checkedCopyFile :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> Annex Bool
+checkedCopyFile :: Key -> OsPath -> OsPath -> Maybe FileMode -> Annex Bool
checkedCopyFile key src dest destmode = catchBoolIO $
checkedCopyFile' key src dest destmode
- =<< liftIO (R.getFileStatus src)
+ =<< liftIO (R.getFileStatus (fromOsPath src))
-checkedCopyFile' :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> FileStatus -> Annex Bool
+checkedCopyFile' :: Key -> OsPath -> OsPath -> Maybe FileMode -> FileStatus -> Annex Bool
checkedCopyFile' key src dest destmode s = catchBoolIO $ do
sz <- liftIO $ getFileSize' src s
- ifM (checkDiskSpace' sz (Just $ P.takeDirectory dest) key 0 True)
+ ifM (checkDiskSpace' sz (Just $ takeDirectory dest) key 0 True)
( liftIO $
- copyFileExternal CopyAllMetaData (fromRawFilePath src) (fromRawFilePath dest)
+ copyFileExternal CopyAllMetaData src dest
<&&> preserveGitMode dest destmode
, return False
)
-preserveGitMode :: RawFilePath -> Maybe FileMode -> IO Bool
+preserveGitMode :: OsPath -> Maybe FileMode -> IO Bool
preserveGitMode f (Just mode)
| isExecutable mode = catchBoolIO $ do
modifyFileMode f $ addModes executeModes
- to be downloaded from the free space. This way, we avoid overcommitting
- when doing concurrent downloads.
-}
-checkDiskSpace :: Maybe FileSize -> Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool
+checkDiskSpace :: Maybe FileSize -> Maybe OsPath -> Key -> Integer -> Bool -> Annex Bool
checkDiskSpace msz destdir key = checkDiskSpace' sz destdir key
where
sz = fromMaybe 1 (fromKey keySize key <|> msz)
-checkDiskSpace' :: FileSize -> Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool
+checkDiskSpace' :: FileSize -> Maybe OsPath -> Key -> Integer -> Bool -> Annex Bool
checkDiskSpace' sz destdir key alreadythere samefilesystem = ifM (Annex.getRead Annex.force)
( return True
, do
inprogress <- if samefilesystem
then sizeOfDownloadsInProgress (/= key)
else pure 0
- dir >>= liftIO . getDiskFree . fromRawFilePath >>= \case
+ dir >>= liftIO . getDiskFree . fromOsPath >>= \case
Just have -> do
reserve <- annexDiskReserve <$> Annex.getGitConfig
let delta = sz + reserve - have - alreadythere + inprogress
-
- Returns an InodeCache if it populated the pointer file.
-}
-populatePointerFile :: Restage -> Key -> RawFilePath -> RawFilePath -> Annex (Maybe InodeCache)
+populatePointerFile :: Restage -> Key -> OsPath -> OsPath -> Annex (Maybe InodeCache)
populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f)
where
go (Just k') | k == k' = do
- destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus f
- liftIO $ removeWhenExistsWith R.removeLink f
+ let f' = fromOsPath f
+ destmode <- liftIO $ catchMaybeIO $
+ fileMode <$> R.getFileStatus f'
+ liftIO $ removeWhenExistsWith R.removeLink f'
(ic, populated) <- replaceWorkTreeFile f $ \tmp -> do
ok <- linkOrCopy k obj tmp destmode >>= \case
Just _ -> thawContent tmp >> return True
then return ic
else return Nothing
go _ = return Nothing
-
+
{- Removes the content from a pointer file, replacing it with a pointer.
-
- Does not check if the pointer file is modified. -}
-depopulatePointerFile :: Key -> RawFilePath -> Annex ()
+depopulatePointerFile :: Key -> OsPath -> Annex ()
depopulatePointerFile key file = do
- st <- liftIO $ catchMaybeIO $ R.getFileStatus file
+ let file' = fromOsPath file
+ st <- liftIO $ catchMaybeIO $ R.getFileStatus file'
let mode = fmap fileMode st
secureErase file
- liftIO $ removeWhenExistsWith R.removeLink file
+ liftIO $ removeWhenExistsWith R.removeLink file'
ic <- replaceWorkTreeFile file $ \tmp -> do
liftIO $ writePointerFile tmp key mode
#if ! defined(mingw32_HOST_OS)
-- Don't advance mtime; this avoids unnecessary re-smudging
-- by git in some cases.
liftIO $ maybe noop
- (\t -> touch tmp t False)
+ (\t -> touch (fromOsPath tmp) t False)
(fmap Posix.modificationTimeHiRes st)
#endif
withTSDelta (liftIO . genInodeCache tmp)
import Annex.Perms
#endif
-import qualified System.FilePath.ByteString as P
-
{- Checks if a given key's content is currently present. -}
inAnnex :: Key -> Annex Bool
-inAnnex key = inAnnexCheck key $ liftIO . R.doesPathExist
+inAnnex key = inAnnexCheck key $ liftIO . R.doesPathExist . fromOsPath
{- Runs an arbitrary check on a key's content. -}
-inAnnexCheck :: Key -> (RawFilePath -> Annex Bool) -> Annex Bool
+inAnnexCheck :: Key -> (OsPath -> Annex Bool) -> Annex Bool
inAnnexCheck key check = inAnnex' id False check key
{- inAnnex that performs an arbitrary check of the key's content. -}
-inAnnex' :: (a -> Bool) -> a -> (RawFilePath -> Annex a) -> Key -> Annex a
+inAnnex' :: (a -> Bool) -> a -> (OsPath -> Annex a) -> Key -> Annex a
inAnnex' isgood bad check key = withObjectLoc key $ \loc -> do
r <- check loc
if isgood r
objectFileExists :: Key -> Annex Bool
objectFileExists key =
calcRepo (gitAnnexLocation key)
- >>= liftIO . R.doesPathExist
+ >>= liftIO . doesFileExist
{- A safer check; the key's content must not only be present, but
- is not in the process of being removed. -}
{- The content file must exist, but the lock file generally
- won't exist unless a removal is in process. -}
checklock (Just lockfile) contentfile =
- ifM (liftIO $ doesFileExist (fromRawFilePath contentfile))
+ ifM (liftIO $ doesFileExist contentfile)
( checkOr is_unlocked lockfile
, return is_missing
)
Just True -> is_locked
Just False -> is_unlocked
#else
- checklock Nothing contentfile = liftIO $ ifM (doesFileExist (fromRawFilePath contentfile))
+ checklock Nothing contentfile = liftIO $ ifM (doesFileExist contentfile)
( lockShared contentfile >>= \case
Nothing -> return is_locked
Just lockhandle -> do
{- In Windows, see if we can take a shared lock. If so,
- remove the lock file to clean up after ourselves. -}
checklock (Just lockfile) contentfile =
- ifM (liftIO $ doesFileExist (fromRawFilePath contentfile))
+ ifM (liftIO $ doesFileExist contentfile)
( modifyContentDir lockfile $ liftIO $
lockShared lockfile >>= \case
Nothing -> return is_locked
- content locking works, from running at the same time as content is locked
- using the old method.
-}
-withContentLockFile :: Key -> (Maybe RawFilePath -> Annex a) -> Annex a
+withContentLockFile :: Key -> (Maybe OsPath -> Annex a) -> Annex a
withContentLockFile k a = do
v <- getVersion
if versionNeedsWritableContentFiles v
- will switch over to v10 content lock files at the
- right time. -}
gitdir <- fromRepo Git.localGitDir
- let gitconfig = gitdir P.</> "config"
+ let gitconfig = gitdir </> literalOsPath "config"
ic <- withTSDelta (liftIO . genInodeCache gitconfig)
oldic <- Annex.getState Annex.gitconfiginodecache
v' <- if fromMaybe False (compareStrong <$> ic <*> oldic)
where
go v = contentLockFile k v >>= a
-contentLockFile :: Key -> Maybe RepoVersion -> Annex (Maybe RawFilePath)
+contentLockFile :: Key -> Maybe RepoVersion -> Annex (Maybe OsPath)
#ifndef mingw32_HOST_OS
{- Older versions of git-annex locked content files themselves, but newer
- versions use a separate lock file, to better support repos shared
#endif
{- Performs an action, passing it the location to use for a key's content. -}
-withObjectLoc :: Key -> (RawFilePath -> Annex a) -> Annex a
+withObjectLoc :: Key -> (OsPath -> Annex a) -> Annex a
withObjectLoc key a = a =<< calcRepo (gitAnnexLocation key)
{- Check if a file contains the unmodified content of the key.
- The expensive way to tell is to do a verification of its content.
- The cheaper way is to see if the InodeCache for the key matches the
- file. -}
-isUnmodified :: Key -> RawFilePath -> Annex Bool
+isUnmodified :: Key -> OsPath -> Annex Bool
isUnmodified key f =
withTSDelta (liftIO . genInodeCache f) >>= \case
Just fc -> do
isUnmodified' key f fc ic
Nothing -> return False
-isUnmodified' :: Key -> RawFilePath -> InodeCache -> [InodeCache] -> Annex Bool
+isUnmodified' :: Key -> OsPath -> InodeCache -> [InodeCache] -> Annex Bool
isUnmodified' = isUnmodifiedLowLevel Database.Keys.addInodeCaches
{- Cheap check if a file contains the unmodified content of the key,
- this may report a false positive when repeated edits are made to a file
- within a small time window (eg 1 second).
-}
-isUnmodifiedCheap :: Key -> RawFilePath -> Annex Bool
+isUnmodifiedCheap :: Key -> OsPath -> Annex Bool
isUnmodifiedCheap key f = maybe (pure False) (isUnmodifiedCheap' key)
=<< withTSDelta (liftIO . genInodeCache f)
import Annex.InodeSentinal
import Utility.InodeCache
-isUnmodifiedLowLevel :: (Key -> [InodeCache] -> Annex ()) -> Key -> RawFilePath -> InodeCache -> [InodeCache] -> Annex Bool
+isUnmodifiedLowLevel :: (Key -> [InodeCache] -> Annex ()) -> Key -> OsPath -> InodeCache -> [InodeCache] -> Annex Bool
isUnmodifiedLowLevel addinodecaches key f fc ic =
isUnmodifiedCheapLowLevel fc ic <||> expensivecheck
where
-- CoW is known to work, so delete
-- dest if it exists in order to do a fast
-- CoW copy.
- void $ tryIO $ removeFile dest
+ void $ tryIO $ removeFile dest'
docopycow
, return False
)
docopycow = watchFileSize dest' meterupdate $ const $
copyCoW CopyTimeStamps src dest
- dest' = toRawFilePath dest
+ dest' = toOsPath dest
-- Check if the dest file already exists, which would prevent
-- probing CoW. If the file exists but is empty, there's no benefit
-- to resuming from it when CoW does not work, so remove it.
destfilealreadypopulated =
- tryIO (R.getFileStatus dest') >>= \case
+ tryIO (R.getFileStatus (toRawFilePath dest)) >>= \case
Left _ -> return False
Right st -> do
sz <- getFileSize' dest' st
if sz == 0
- then tryIO (removeFile dest) >>= \case
+ then tryIO (removeFile dest') >>= \case
Right () -> return False
Left _ -> return True
else return True
docopy = do
-- The file might have had the write bit removed,
-- so make sure we can write to it.
- void $ tryIO $ allowWrite dest'
+ void $ tryIO $ allowWrite (toOsPath dest)
withBinaryFile src ReadMode $ \hsrc ->
fileContentCopier hsrc dest meterupdate iv
-- Copy src mode and mtime.
mode <- fileMode <$> R.getFileStatus (toRawFilePath src)
- mtime <- utcTimeToPOSIXSeconds <$> getModificationTime src
+ mtime <- utcTimeToPOSIXSeconds
+ <$> getModificationTime (toOsPath src)
R.setFileMode dest' mode
touch dest' mtime False
import qualified Data.ByteArray as BA
import qualified Data.ByteArray.Encoding as BA
import qualified Data.ByteString as S
-import qualified System.FilePath.ByteString as P
import Common
import Key
import Utility.Hash
import Utility.MD5
-type Hasher = Key -> RawFilePath
+type Hasher = Key -> OsPath
-- Number of hash levels to use. 2 is the default.
newtype HashLevels = HashLevels Int
| hasDifference d (annexDifferences config) = HashLevels 1
| otherwise = def
-branchHashDir :: GitConfig -> Key -> S.ByteString
+branchHashDir :: GitConfig -> Key -> OsPath
branchHashDir = hashDirLower . branchHashLevels
{- Two different directory hashes may be used. The mixed case hash
dirHashes :: NE.NonEmpty (HashLevels -> Hasher)
dirHashes = hashDirLower NE.:| [hashDirMixed]
-hashDirs :: HashLevels -> Int -> S.ByteString -> RawFilePath
-hashDirs (HashLevels 1) sz s = P.addTrailingPathSeparator $ S.take sz s
-hashDirs _ sz s = P.addTrailingPathSeparator $ h P.</> t
+hashDirs :: HashLevels -> Int -> S.ByteString -> OsPath
+hashDirs (HashLevels 1) sz s = addTrailingPathSeparator $
+ toOsPath (S.take sz s)
+hashDirs _ sz s = addTrailingPathSeparator $ toOsPath h </> toOsPath t
where
(h, t) = S.splitAt sz s
[ "dropped"
, case afile of
AssociatedFile Nothing -> serializeKey key
- AssociatedFile (Just af) -> fromRawFilePath af
+ AssociatedFile (Just af) -> fromOsPath af
, "(from " ++ maybe "here" show u ++ ")"
, "(copies now " ++ show (have - 1) ++ ")"
, ": " ++ reason
runerr (Just cmd) =
return $ Left $ ProgramFailure $
- "Cannot run " ++ cmd ++ " -- Make sure it's executable and that its dependencies are installed."
+ "Cannot run " ++ fromOsPath cmd ++ " -- Make sure it's executable and that its dependencies are installed."
runerr Nothing = do
- path <- intercalate ":" <$> getSearchPath
+ path <- intercalate ":" . map fromOsPath <$> getSearchPath
return $ Left $ ProgramNotInstalled $
"Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")"
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Annex.FileMatcher (
import qualified Data.Set as S
import Control.Monad.Writer
-type GetFileMatcher = RawFilePath -> Annex (FileMatcher Annex)
+type GetFileMatcher = OsPath -> Annex (FileMatcher Annex)
-checkFileMatcher :: LiveUpdate -> GetFileMatcher -> RawFilePath -> Annex Bool
+checkFileMatcher :: LiveUpdate -> GetFileMatcher -> OsPath -> Annex Bool
checkFileMatcher lu getmatcher file =
checkFileMatcher' lu getmatcher file (return True)
-- | Allows running an action when no matcher is configured for the file.
-checkFileMatcher' :: LiveUpdate -> GetFileMatcher -> RawFilePath -> Annex Bool -> Annex Bool
+checkFileMatcher' :: LiveUpdate -> GetFileMatcher -> OsPath -> Annex Bool -> Annex Bool
checkFileMatcher' lu getmatcher file notconfigured = do
matcher <- getmatcher file
checkMatcher matcher Nothing afile lu S.empty notconfigured d
fromMaybe mempty descmsg <> UnquotedString s
return False
-fileMatchInfo :: RawFilePath -> Maybe Key -> Annex MatchInfo
+fileMatchInfo :: OsPath -> Maybe Key -> Annex MatchInfo
fileMatchInfo file mkey = do
matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
return $ MatchingFile FileInfo
tokenizeMatcher :: String -> [String]
tokenizeMatcher = filter (not . null) . concatMap splitparens . words
where
- splitparens = segmentDelim (`elem` "()")
+ splitparens = segmentDelim (`elem` ("()" :: String))
commonTokens :: LimitBy -> [ParseToken (MatchFiles Annex)]
commonTokens lb =
, ValueToken "fullysizebalanced" (usev $ limitFullySizeBalanced (repoUUID pcd) (getGroupMap pcd))
] ++ commonTokens LimitAnnexFiles
where
- preferreddir = maybe "public" fromProposedAccepted $
+ preferreddir = toOsPath $ maybe "public" fromProposedAccepted $
M.lookup preferreddirField =<< (`M.lookup` configMap pcd) =<< repoUUID pcd
preferredContentParser :: [ParseToken (MatchFiles Annex)] -> String -> [ParseResult (MatchFiles Annex)]
import Utility.Directory
import Utility.Exception
import Utility.Monad
-import Utility.FileSystemEncoding
import Utility.SystemDirectory
+import Utility.OsPath
import qualified Utility.RawFilePath as R
import Utility.PartialPrelude
+import qualified Utility.OsString as OS
import System.IO
import Data.List
import Control.Monad
import Control.Monad.IfElse
import qualified Data.Map as M
-import qualified Data.ByteString as S
-import System.FilePath.ByteString
import Control.Applicative
import Prelude
, return r
)
where
- dotgit = w </> ".git"
+ dotgit = w </> literalOsPath ".git"
- replacedotgit = whenM (doesFileExist (fromRawFilePath dotgit)) $ do
+ replacedotgit = whenM (doesFileExist dotgit) $ do
linktarget <- relPathDirToFile w d
- removeWhenExistsWith R.removeLink dotgit
- R.createSymbolicLink linktarget dotgit
+ let dotgit' = fromOsPath dotgit
+ removeWhenExistsWith R.removeLink dotgit'
+ R.createSymbolicLink (fromOsPath linktarget) dotgit'
-- Unsetting a config fails if it's not set, so ignore failure.
unsetcoreworktree = void $ Git.Config.unset "core.worktree" r
- worktreefixup =
+ worktreefixup = do
-- git-worktree sets up a "commondir" file that contains
-- the path to the main git directory.
-- Using --separate-git-dir does not.
- catchDefaultIO Nothing (headMaybe . lines <$> readFile (fromRawFilePath (d </> "commondir"))) >>= \case
+ let commondirfile = fromOsPath (d </> literalOsPath "commondir")
+ catchDefaultIO Nothing (headMaybe . lines <$> readFile commondirfile) >>= \case
Just gd -> do
-- Make the worktree's git directory
-- contain an annex symlink to the main
-- repository's annex directory.
- let linktarget = toRawFilePath gd </> "annex"
- R.createSymbolicLink linktarget
- (dotgit </> "annex")
+ let linktarget = toOsPath gd </> literalOsPath "annex"
+ R.createSymbolicLink (fromOsPath linktarget) $
+ fromOsPath $ dotgit </> literalOsPath "annex"
Nothing -> return ()
-- Repo adjusted, so that symlinks to objects that get checked
needsSubmoduleFixup :: Repo -> Bool
needsSubmoduleFixup (Repo { location = (Local { worktree = Just _, gitdir = d }) }) =
- (".git" </> "modules") `S.isInfixOf` d
+ (literalOsPath ".git" </> literalOsPath "modules") `OS.isInfixOf` d
needsSubmoduleFixup _ = False
needsGitLinkFixup :: Repo -> IO Bool
-- Optimization: Avoid statting .git in the common case; only
-- when the gitdir is not in the usual place inside the worktree
-- might .git be a file.
- | wt </> ".git" == d = return False
- | otherwise = doesFileExist (fromRawFilePath (wt </> ".git"))
+ | wt </> literalOsPath ".git" == d = return False
+ | otherwise = doesFileExist (wt </> literalOsPath ".git")
needsGitLinkFixup _ = return False
import Config.Smudge
{- Runs an action using a different git index file. -}
-withIndexFile :: AltIndexFile -> (FilePath -> Annex a) -> Annex a
+withIndexFile :: AltIndexFile -> (OsPath -> Annex a) -> Annex a
withIndexFile i = withAltRepo usecachedgitenv restoregitenv
where
-- This is an optimisation. Since withIndexFile is run repeatedly,
f <- indexEnvVal $ case i of
AnnexIndexFile -> gitAnnexIndex g
ViewIndexFile -> gitAnnexViewIndex g
- g' <- addGitEnv g indexEnv f
+ g' <- addGitEnv g indexEnv (fromOsPath f)
return (g', f)
restoregitenv g g' = g' { gitEnv = gitEnv g }
{- Runs an action using a different git work tree.
-
- Smudge and clean filters are disabled in this work tree. -}
-withWorkTree :: FilePath -> Annex a -> Annex a
+withWorkTree :: OsPath -> Annex a -> Annex a
withWorkTree d a = withAltRepo
(\g -> return $ (g { location = modlocation (location g), gitGlobalOpts = gitGlobalOpts g ++ bypassSmudgeConfig }, ()))
(\g g' -> g' { location = location g, gitGlobalOpts = gitGlobalOpts g })
(const a)
where
- modlocation l@(Local {}) = l { worktree = Just (toRawFilePath d) }
+ modlocation l@(Local {}) = l { worktree = Just d }
modlocation _ = giveup "withWorkTree of non-local git repo"
{- Runs an action with the git index file and HEAD, and a few other
-
- Needs git 2.2.0 or newer.
-}
-withWorkTreeRelated :: FilePath -> Annex a -> Annex a
+withWorkTreeRelated :: OsPath -> Annex a -> Annex a
withWorkTreeRelated d a = withAltRepo modrepo unmodrepo (const a)
where
modrepo g = liftIO $ do
- g' <- addGitEnv g "GIT_COMMON_DIR" . fromRawFilePath
+ g' <- addGitEnv g "GIT_COMMON_DIR" . fromOsPath
=<< absPath (localGitDir g)
- g'' <- addGitEnv g' "GIT_DIR" d
+ g'' <- addGitEnv g' "GIT_DIR" (fromOsPath d)
return (g'' { gitEnvOverridesGitDir = True }, ())
unmodrepo g g' = g'
{ gitEnv = gitEnv g
liftIO $ freeResourcePool p Git.HashObject.hashObjectStop
Annex.changeState $ \s -> s { Annex.hashobjecthandle = Nothing }
-hashFile :: RawFilePath -> Annex Sha
+hashFile :: OsPath -> Annex Sha
hashFile f = withHashObjectHandle $ \h ->
liftIO $ Git.HashObject.hashFile h f
import qualified Data.Map as M
preCommitHook :: Git.Hook
-preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .") []
+preCommitHook = Git.Hook (literalOsPath "pre-commit")
+ (mkHookScript "git annex pre-commit .") []
postReceiveHook :: Git.Hook
-postReceiveHook = Git.Hook "post-receive"
+postReceiveHook = Git.Hook (literalOsPath "post-receive")
-- Only run git-annex post-receive when git-annex supports it,
-- to avoid failing if the repository with this hook is used
-- with an older version of git-annex.
]
postCheckoutHook :: Git.Hook
-postCheckoutHook = Git.Hook "post-checkout" smudgeHook []
+postCheckoutHook = Git.Hook (literalOsPath "post-checkout") smudgeHook []
postMergeHook :: Git.Hook
-postMergeHook = Git.Hook "post-merge" smudgeHook []
+postMergeHook = Git.Hook (literalOsPath "post-merge") smudgeHook []
-- Older versions of git-annex didn't support this command, but neither did
-- they support v7 repositories.
smudgeHook = mkHookScript "git annex smudge --update"
preCommitAnnexHook :: Git.Hook
-preCommitAnnexHook = Git.Hook "pre-commit-annex" "" []
+preCommitAnnexHook = Git.Hook (literalOsPath "pre-commit-annex") "" []
postUpdateAnnexHook :: Git.Hook
-postUpdateAnnexHook = Git.Hook "post-update-annex" "" []
+postUpdateAnnexHook = Git.Hook (literalOsPath "post-update-annex") "" []
preInitAnnexHook :: Git.Hook
-preInitAnnexHook = Git.Hook "pre-init-annex" "" []
+preInitAnnexHook = Git.Hook (literalOsPath "pre-init-annex") "" []
freezeContentAnnexHook :: Git.Hook
-freezeContentAnnexHook = Git.Hook "freezecontent-annex" "" []
+freezeContentAnnexHook = Git.Hook (literalOsPath "freezecontent-annex") "" []
thawContentAnnexHook :: Git.Hook
-thawContentAnnexHook = Git.Hook "thawcontent-annex" "" []
+thawContentAnnexHook = Git.Hook (literalOsPath "thawcontent-annex") "" []
secureEraseAnnexHook :: Git.Hook
-secureEraseAnnexHook = Git.Hook "secure-erase-annex" "" []
+secureEraseAnnexHook = Git.Hook (literalOsPath "secure-erase-annex") "" []
commitMessageAnnexHook :: Git.Hook
-commitMessageAnnexHook = Git.Hook "commitmessage-annex" "" []
+commitMessageAnnexHook = Git.Hook (literalOsPath "commitmessage-annex") "" []
httpHeadersAnnexHook :: Git.Hook
-httpHeadersAnnexHook = Git.Hook "http-headers-annex" "" []
+httpHeadersAnnexHook = Git.Hook (literalOsPath "http-headers-annex") "" []
mkHookScript :: String -> String
mkHookScript s = unlines
hookWarning h msg = do
r <- gitRepo
warning $ UnquotedString $
- fromRawFilePath (Git.hookName h) ++
- " hook (" ++ fromRawFilePath (Git.hookFile h r) ++ ") " ++ msg
+ fromOsPath (Git.hookName h) ++
+ " hook (" ++ fromOsPath (Git.hookFile h r) ++ ") " ++ msg
{- To avoid checking if the hook exists every time, the existing hooks
- are cached. -}
( return Nothing
, do
h <- fromRepo (Git.hookFile hook)
- commandfailed (fromRawFilePath h)
+ commandfailed (fromOsPath h)
)
runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case
Nothing -> return Nothing
)
commandfailed c = return $ Just c
-runAnnexPathHook :: String -> Git.Hook -> (GitConfig -> Maybe String) -> RawFilePath -> Annex Bool
+runAnnexPathHook :: String -> Git.Hook -> (GitConfig -> Maybe String) -> OsPath -> Annex Bool
runAnnexPathHook pathtoken hook commandcfg p = ifM (doesAnnexHookExist hook)
( runhook
, runcommandcfg
)
where
- runhook = inRepo $ Git.runHook boolSystem hook [ File (fromRawFilePath p) ]
+ runhook = inRepo $ Git.runHook boolSystem hook [ File p' ]
runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case
Nothing -> return True
Just basecmd -> liftIO $
boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
- gencmd = massReplace [ (pathtoken, shellEscape (fromRawFilePath p)) ]
+ gencmd = massReplace [ (pathtoken, shellEscape p') ]
+ p' = fromOsPath p
outputOfAnnexHook :: Git.Hook -> (GitConfig -> Maybe String) -> Annex (Maybe String)
outputOfAnnexHook hook commandcfg = ifM (doesAnnexHookExist hook)
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified System.FilePath.Posix.ByteString as Posix
-import qualified System.FilePath.ByteString as P
import qualified Data.ByteArray.Encoding as BA
{- Configures how to build an import tree. -}
let subtreeref = Ref $
fromRef' finaltree
<> ":"
- <> getTopFilePath dir
+ <> fromOsPath (getTopFilePath dir)
in fromMaybe emptyTree
<$> inRepo (Git.Ref.tree subtreeref)
updateexportdb importedtree
lf = fromImportLocation loc
treepath = asTopFilePath lf
topf = asTopFilePath $
- maybe lf (\sd -> getTopFilePath sd P.</> lf) msubdir
+ maybe lf (\sd -> getTopFilePath sd </> lf) msubdir
mklink k = do
relf <- fromRepo $ fromTopFilePath topf
symlink <- calcRepo $ gitAnnexLink relf k
- linksha <- hashSymlink symlink
+ linksha <- hashSymlink (fromOsPath symlink)
return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha
mkpointer k = TreeItem treepath (fromTreeItemType TreeFile)
<$> hashPointerFile k
-- Full directory prefix where the sub tree is located.
let fullprefix = asTopFilePath $ case msubdir of
Nothing -> subdir
- Just d -> getTopFilePath d Posix.</> subdir
+ Just d -> toOsPath $
+ fromOsPath (getTopFilePath d) Posix.</> fromOsPath subdir
Tree ts <- converttree (Just fullprefix) $
map (\(p, i) -> (mkImportLocation p, i))
(importableContentsSubTree c)
let af = AssociatedFile (Just f)
let downloader p' tmpfile = do
_ <- Remote.retrieveExportWithContentIdentifier
- ia loc [cid] (fromRawFilePath tmpfile)
+ ia loc [cid] tmpfile
(Left k)
(combineMeterUpdate p' p)
ok <- moveAnnex k af tmpfile
doimportsmall cidmap loc cid sz p = do
let downloader tmpfile = do
(k, _) <- Remote.retrieveExportWithContentIdentifier
- ia loc [cid] (fromRawFilePath tmpfile)
+ ia loc [cid] tmpfile
(Right (mkkey tmpfile))
p
case keyGitSha k of
let af = AssociatedFile (Just f)
let downloader tmpfile p = do
(k, _) <- Remote.retrieveExportWithContentIdentifier
- ia loc [cid] (fromRawFilePath tmpfile)
+ ia loc [cid] tmpfile
(Right (mkkey tmpfile))
p
case keyGitSha k of
case importtreeconfig of
ImportTree -> fromImportLocation loc
ImportSubTree subdir _ ->
- getTopFilePath subdir P.</> fromImportLocation loc
+ getTopFilePath subdir </> fromImportLocation loc
getcidkey cidmap db cid = liftIO $
-- Avoiding querying the database when it's empty speeds up
isknown <||> (matches <&&> notignored)
where
-- Checks, from least to most expensive.
- ingitdir = ".git" `elem` Posix.splitDirectories (fromImportLocation loc)
+ ingitdir = ".git" `elem` Posix.splitDirectories (fromOsPath (fromImportLocation loc))
matches = matchesImportLocation matcher loc sz
isknown = isKnownImportLocation dbhandle loc
notignored = notIgnoredImportLocation importtreeconfig ci loc
where
f = case importtreeconfig of
ImportSubTree dir _ ->
- getTopFilePath dir P.</> fromImportLocation loc
+ getTopFilePath dir </> fromImportLocation loc
ImportTree ->
fromImportLocation loc
data LockDownConfig = LockDownConfig
{ lockingFile :: Bool
-- ^ write bit removed during lock down
- , hardlinkFileTmpDir :: Maybe RawFilePath
+ , hardlinkFileTmpDir :: Maybe OsPath
-- ^ hard link to temp directory
, checkWritePerms :: Bool
-- ^ check that write perms are successfully removed
- Lockdown can fail if a file gets deleted, or if it's unable to remove
- write permissions, and Nothing will be returned.
-}
-lockDown :: LockDownConfig-> FilePath -> Annex (Maybe LockedDown)
+lockDown :: LockDownConfig-> OsPath -> Annex (Maybe LockedDown)
lockDown cfg file = either
(\e -> warning (UnquotedString (show e)) >> return Nothing)
(return . Just)
=<< lockDown' cfg file
-lockDown' :: LockDownConfig -> FilePath -> Annex (Either SomeException LockedDown)
+lockDown' :: LockDownConfig -> OsPath -> Annex (Either SomeException LockedDown)
lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem
( nohardlink
, case hardlinkFileTmpDir cfg of
Just tmpdir -> withhardlink tmpdir
)
where
- file' = toRawFilePath file
-
nohardlink = do
setperms
withTSDelta $ liftIO . nohardlink'
nohardlink' delta = do
- cache <- genInodeCache file' delta
+ cache <- genInodeCache file delta
return $ LockedDown cfg $ KeySource
- { keyFilename = file'
- , contentLocation = file'
+ { keyFilename = file
+ , contentLocation = file
, inodeCache = cache
}
withhardlink tmpdir = do
setperms
withTSDelta $ \delta -> liftIO $ do
- (tmpfile, h) <- openTmpFileIn (toOsPath tmpdir) $
- relatedTemplate $ toRawFilePath $
- "ingest-" ++ takeFileName file
+ (tmpfile, h) <- openTmpFileIn tmpdir $
+ relatedTemplate $ fromOsPath $
+ literalOsPath "ingest-" <> takeFileName file
hClose h
- let tmpfile' = fromOsPath tmpfile
- removeWhenExistsWith R.removeLink tmpfile'
- withhardlink' delta tmpfile'
+ removeWhenExistsWith R.removeLink (fromOsPath tmpfile)
+ withhardlink' delta tmpfile
`catchIO` const (nohardlink' delta)
withhardlink' delta tmpfile = do
- R.createLink file' tmpfile
+ R.createLink (fromOsPath file) (fromOsPath tmpfile)
cache <- genInodeCache tmpfile delta
return $ LockedDown cfg $ KeySource
- { keyFilename = file'
+ { keyFilename = file
, contentLocation = tmpfile
, inodeCache = cache
}
setperms = when (lockingFile cfg) $ do
- freezeContent file'
+ freezeContent file
when (checkWritePerms cfg) $ do
qp <- coreQuotePath <$> Annex.getGitConfig
maybe noop (giveup . decodeBS . quote qp)
- =<< checkLockedDownWritePerms file' file'
+ =<< checkLockedDownWritePerms file file
-checkLockedDownWritePerms :: RawFilePath -> RawFilePath -> Annex (Maybe StringContainingQuotedPath)
+checkLockedDownWritePerms :: OsPath -> OsPath -> Annex (Maybe StringContainingQuotedPath)
checkLockedDownWritePerms file displayfile = checkContentWritePerm file >>= return . \case
Just False -> Just $ "Unable to remove all write permissions from "
<> QuotedPath displayfile
then addSymlink f k mic
else do
mode <- liftIO $ catchMaybeIO $
- fileMode <$> R.getFileStatus (contentLocation source)
+ fileMode <$> R.getFileStatus
+ (fromOsPath (contentLocation source))
stagePointerFile f mode =<< hashPointerFile k
return (Just k)
fst <$> genKey source meterupdate backend
Just k -> return k
let src = contentLocation source
- ms <- liftIO $ catchMaybeIO $ R.getFileStatus src
+ ms <- liftIO $ catchMaybeIO $ R.getFileStatus (fromOsPath src)
mcache <- maybe (pure Nothing) (liftIO . toInodeCache delta src) ms
case (mcache, inodeCache source) of
(_, Nothing) -> go k mcache
cleanCruft :: KeySource -> Annex ()
cleanCruft source = when (contentLocation source /= keyFilename source) $
- liftIO $ removeWhenExistsWith R.removeLink $ contentLocation source
+ liftIO $ removeWhenExistsWith removeFile $ contentLocation source
-- If a worktree file was was hard linked to an annex object before,
-- modifying the file would have caused the object to have the wrong
-- content. Clean up from that.
-cleanOldKeys :: RawFilePath -> Key -> Annex ()
+cleanOldKeys :: OsPath -> Key -> Annex ()
cleanOldKeys file newkey = do
g <- Annex.gitRepo
topf <- inRepo (toTopFilePath file)
{- On error, put the file back so it doesn't seem to have vanished.
- This can be called before or after the symlink is in place. -}
-restoreFile :: RawFilePath -> Key -> SomeException -> Annex a
+restoreFile :: OsPath -> Key -> SomeException -> Annex a
restoreFile file key e = do
whenM (inAnnex key) $ do
- liftIO $ removeWhenExistsWith R.removeLink file
+ liftIO $ removeWhenExistsWith removeFile file
-- The key could be used by other files too, so leave the
-- content in the annex, and make a copy back to the file.
- obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
- unlessM (liftIO $ copyFileExternal CopyTimeStamps obj (fromRawFilePath file)) $
- warning $ "Unable to restore content of " <> QuotedPath file <> "; it should be located in " <> QuotedPath (toRawFilePath obj)
+ obj <- calcRepo (gitAnnexLocation key)
+ unlessM (liftIO $ copyFileExternal CopyTimeStamps obj file) $
+ warning $ "Unable to restore content of " <> QuotedPath file <> "; it should be located in " <> QuotedPath obj
thawContent file
throwM e
{- Creates the symlink to the annexed content, returns the link target. -}
-makeLink :: RawFilePath -> Key -> Maybe InodeCache -> Annex LinkTarget
+makeLink :: OsPath -> Key -> Maybe InodeCache -> Annex LinkTarget
makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
- l <- calcRepo $ gitAnnexLink file key
+ l <- fromOsPath <$> calcRepo (gitAnnexLink file key)
replaceWorkTreeFile file $ makeAnnexLink l
-- touch symlink to have same time as the original file,
-- as provided in the InodeCache
case mcache of
- Just c -> liftIO $ touch file (inodeCacheToMtime c) False
+ Just c -> liftIO $
+ touch (fromOsPath file) (inodeCacheToMtime c) False
Nothing -> noop
return l
{- Creates the symlink to the annexed content, and stages it in git. -}
-addSymlink :: RawFilePath -> Key -> Maybe InodeCache -> Annex ()
+addSymlink :: OsPath -> Key -> Maybe InodeCache -> Annex ()
addSymlink file key mcache = stageSymlink file =<< genSymlink file key mcache
-genSymlink :: RawFilePath -> Key -> Maybe InodeCache -> Annex Git.Sha
+genSymlink :: OsPath -> Key -> Maybe InodeCache -> Annex Git.Sha
genSymlink file key mcache = do
linktarget <- makeLink file key mcache
hashSymlink linktarget
-
- When the content of the key is not accepted into the annex, returns False.
-}
-addAnnexedFile :: AddUnlockedMatcher -> RawFilePath -> Key -> Maybe RawFilePath -> Annex Bool
+addAnnexedFile :: AddUnlockedMatcher -> OsPath -> Key -> Maybe OsPath -> Annex Bool
addAnnexedFile matcher file key mtmp = ifM (addUnlocked matcher mi (isJust mtmp))
( do
mode <- maybe
(pure Nothing)
- (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus tmp)
+ (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath tmp))
mtmp
stagePointerFile file mode =<< hashPointerFile key
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
{- Use with actions that add an already existing annex symlink or pointer
- file. The warning avoids a confusing situation where the file got copied
- from another git-annex repo, probably by accident. -}
-addingExistingLink :: RawFilePath -> Key -> Annex a -> Annex a
+addingExistingLink :: OsPath -> Key -> Annex a -> Annex a
addingExistingLink f k a = do
unlessM (isKnownKey k <||> inAnnex k) $ do
islink <- isJust <$> isAnnexLink f
#ifndef mingw32_HOST_OS
import Utility.ThreadScheduler
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import Utility.FileMode
import System.Posix.User
import qualified Utility.LockFile.Posix as Posix
#ifndef mingw32_HOST_OS
import System.PosixCompat.Files (ownerReadMode, isNamedPipe)
import Data.Either
-import qualified System.FilePath.ByteString as P
import Control.Concurrent.Async
#endif
Just _ -> return False
noAnnexFileContent' :: Annex (Maybe String)
-noAnnexFileContent' = inRepo $
- noAnnexFileContent . fmap fromRawFilePath . Git.repoWorkTree
+noAnnexFileContent' = inRepo $ noAnnexFileContent . Git.repoWorkTree
genDescription :: Maybe String -> Annex UUIDDesc
genDescription (Just d) = return $ UUIDDesc $ encodeBS d
genDescription Nothing = do
- reldir <- liftIO . relHome . fromRawFilePath
+ reldir <- liftIO . relHome
=<< liftIO . absPath
=<< fromRepo Git.repoPath
hostname <- fromMaybe "" <$> liftIO getHostname
let at = if null hostname then "" else "@"
v <- liftIO myUserName
return $ UUIDDesc $ encodeBS $ concat $ case v of
- Right username -> [username, at, hostname, ":", reldir]
- Left _ -> [hostname, ":", reldir]
+ Right username -> [username, at, hostname, ":", fromOsPath reldir]
+ Left _ -> [hostname, ":", fromOsPath reldir]
initialize :: Annex () -> Maybe String -> Maybe RepoVersion -> Annex ()
initialize startupannex mdescription mversion = checkInitializeAllowed $ \initallowed -> do
objectDirNotPresent :: Annex Bool
objectDirNotPresent = do
- d <- fromRawFilePath <$> fromRepo gitAnnexObjectDir
+ d <- fromRepo gitAnnexObjectDir
exists <- liftIO $ doesDirectoryExist d
when exists $ guardSafeToUseRepo $
giveup $ unwords $
[ "This repository is not initialized for use"
- , "by git-annex, but " ++ d ++ " exists,"
+ , "by git-annex, but " ++ fromOsPath d ++ " exists,"
, "which indicates this repository was used by"
, "git-annex before, and may have lost its"
, "annex.uuid and annex.version configs. Either"
, ""
-- This mirrors git's wording.
, "To add an exception for this directory, call:"
- , "\tgit config --global --add safe.directory " ++ fromRawFilePath p
+ , "\tgit config --global --add safe.directory " ++ fromOsPath p
]
, a
)
probeCrippledFileSystem'
:: (MonadIO m, MonadCatch m)
- => RawFilePath
- -> Maybe (RawFilePath -> m ())
- -> Maybe (RawFilePath -> m ())
+ => OsPath
+ -> Maybe (OsPath -> m ())
+ -> Maybe (OsPath -> m ())
-> Bool
-> m (Bool, [String])
#ifdef mingw32_HOST_OS
probeCrippledFileSystem' _ _ _ _ = return (True, [])
#else
probeCrippledFileSystem' tmp freezecontent thawcontent hasfreezehook = do
- let f = tmp P.</> "gaprobe"
- let f' = fromRawFilePath f
- liftIO $ writeFile f' ""
- r <- probe f'
+ let f = tmp </> literalOsPath "gaprobe"
+ liftIO $ F.writeFile' f ""
+ r <- probe f
void $ tryNonAsync $ (fromMaybe (liftIO . allowWrite) thawcontent) f
- liftIO $ removeFile f'
+ liftIO $ removeFile f
return r
where
probe f = catchDefaultIO (True, []) $ do
- let f2 = f ++ "2"
- liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2)
- liftIO $ R.createSymbolicLink (toRawFilePath f) (toRawFilePath f2)
- liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2)
- (fromMaybe (liftIO . preventWrite) freezecontent) (toRawFilePath f)
+ let f2 = f <> literalOsPath "2"
+ liftIO $ removeWhenExistsWith removeFile f2
+ liftIO $ R.createSymbolicLink (fromOsPath f) (fromOsPath f2)
+ liftIO $ removeWhenExistsWith removeFile f2
+ (fromMaybe (liftIO . preventWrite) freezecontent) f
-- Should be unable to write to the file (unless
-- running as root). But some crippled
-- filesystems ignore write bit removals or ignore
-- permissions entirely.
- ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared (toRawFilePath f) Nothing hasfreezehook))
+ ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared f Nothing hasfreezehook))
( return (True, ["Filesystem does not allow removing write bit from files."])
, liftIO $ ifM ((== 0) <$> getRealUserID)
( return (False, [])
, do
r <- catchBoolIO $ do
- writeFile f "2"
+ F.writeFile' f "2"
return True
if r
then return (True, ["Filesystem allows writing to files whose write bit is not set."])
probeLockSupport = return True
#else
probeLockSupport = withEventuallyCleanedOtherTmp $ \tmp -> do
- let f = tmp P.</> "lockprobe"
+ let f = tmp </> literalOsPath "lockprobe"
mode <- annexFileMode
annexrunner <- Annex.makeRunner
liftIO $ withAsync (warnstall annexrunner) (const (go f mode))
where
go f mode = do
- removeWhenExistsWith R.removeLink f
+ removeWhenExistsWith removeFile f
let locktest = bracket
(Posix.lockExclusive (Just mode) f)
Posix.dropLock
(const noop)
ok <- isRight <$> tryNonAsync locktest
- removeWhenExistsWith R.removeLink f
+ removeWhenExistsWith removeFile f
return ok
warnstall annexrunner = do
return False
#else
withEventuallyCleanedOtherTmp $ \tmp -> do
- let f = tmp P.</> "gaprobe"
- let f2 = tmp P.</> "gaprobe2"
+ let f = tmp </> literalOsPath "gaprobe"
+ let f2 = tmp </> literalOsPath "gaprobe2"
liftIO $ do
- removeWhenExistsWith R.removeLink f
- removeWhenExistsWith R.removeLink f2
+ removeWhenExistsWith removeFile f
+ removeWhenExistsWith removeFile f2
ms <- tryIO $ do
- R.createNamedPipe f ownerReadMode
- R.createLink f f2
- R.getFileStatus f
- removeWhenExistsWith R.removeLink f
- removeWhenExistsWith R.removeLink f2
+ R.createNamedPipe (fromOsPath f) ownerReadMode
+ R.createLink (fromOsPath f) (fromOsPath f2)
+ R.getFileStatus (fromOsPath f)
+ removeWhenExistsWith removeFile f
+ removeWhenExistsWith removeFile f2
return $ either (const False) isNamedPipe ms
#endif
-- could result in password prompts for http credentials,
-- which would then not end up cached in this process's state.
_ <- remotelist
- rp <- fromRawFilePath <$> fromRepo Git.repoPath
+ rp <- fromRepo Git.repoPath
withNullHandle $ \nullh -> gitAnnexChildProcess "init"
[ Param "--autoenable" ]
(\p -> p
{ std_out = UseHandle nullh
, std_err = UseHandle nullh
, std_in = UseHandle nullh
- , cwd = Just rp
+ , cwd = Just (fromOsPath rp)
}
)
(\_ _ _ pid -> void $ waitForProcess pid)
{- Checks if one of the provided old InodeCache matches the current
- version of a file. -}
-sameInodeCache :: RawFilePath -> [InodeCache] -> Annex Bool
+sameInodeCache :: OsPath -> [InodeCache] -> Annex Bool
sameInodeCache file [] = do
fastDebug "Annex.InodeSentinal" $
- fromRawFilePath file ++ " inode cache empty"
+ fromOsPath file ++ " inode cache empty"
return False
sameInodeCache file old = go =<< withTSDelta (liftIO . genInodeCache file)
where
go Nothing = do
fastDebug "Annex.InodeSentinal" $
- fromRawFilePath file ++ " not present, cannot compare with inode cache"
+ fromOsPath file ++ " not present, cannot compare with inode cache"
return False
go (Just curr) = ifM (elemInodeCaches curr old)
( return True
, do
fastDebug "Annex.InodeSentinal" $
- fromRawFilePath file ++ " (" ++ show curr ++ ") does not match inode cache (" ++ show old ++ ")"
+ fromOsPath file ++ " (" ++ show curr ++ ") does not match inode cache (" ++ show old ++ ")"
return False
)
alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile
hasobjects
| evenwithobjects = pure False
- | otherwise = liftIO . doesDirectoryExist . fromRawFilePath
+ | otherwise = liftIO . doesDirectoryExist
=<< fromRepo gitAnnexObjectDir
annexSentinalFile :: Annex SentinalFile
import Annex.BranchState
import Types.BranchState
import Utility.Directory.Stream
-import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
+import qualified Utility.OsString as OS
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as B
-import qualified System.FilePath.ByteString as P
import Data.ByteString.Builder
import Data.Char
- interrupted write truncating information that was earlier read from the
- file, and so losing data.
-}
-setJournalFile :: Journalable content => JournalLocked -> RegardingUUID -> RawFilePath -> content -> Annex ()
+setJournalFile :: Journalable content => JournalLocked -> RegardingUUID -> OsPath -> content -> Annex ()
setJournalFile _jl ru file content = withOtherTmp $ \tmp -> do
st <- getState
jd <- fromRepo =<< ifM (regardingPrivateUUID ru)
)
-- journal file is written atomically
let jfile = journalFile file
- let tmpfile = tmp P.</> jfile
- liftIO $ F.withFile (toOsPath tmpfile) WriteMode $ \h ->
+ let tmpfile = tmp </> jfile
+ liftIO $ F.withFile tmpfile WriteMode $ \h ->
writeJournalHandle h content
- let dest = jd P.</> jfile
+ let dest = jd </> jfile
let mv = do
liftIO $ moveFile tmpfile dest
setAnnexFilePerm dest
-- exists
mv `catchIO` (const (createAnnexDirectory jd >> mv))
-newtype AppendableJournalFile = AppendableJournalFile (RawFilePath, RawFilePath)
+newtype AppendableJournalFile = AppendableJournalFile (OsPath, OsPath)
{- If the journal file does not exist, it cannot be appended to, because
- that would overwrite whatever content the file has in the git-annex
- branch. -}
-checkCanAppendJournalFile :: JournalLocked -> RegardingUUID -> RawFilePath -> Annex (Maybe AppendableJournalFile)
+checkCanAppendJournalFile :: JournalLocked -> RegardingUUID -> OsPath -> Annex (Maybe AppendableJournalFile)
checkCanAppendJournalFile _jl ru file = do
st <- getState
jd <- fromRepo =<< ifM (regardingPrivateUUID ru)
( return (gitAnnexPrivateJournalDir st)
, return (gitAnnexJournalDir st)
)
- let jfile = jd P.</> journalFile file
- ifM (liftIO $ R.doesPathExist jfile)
+ let jfile = jd </> journalFile file
+ ifM (liftIO $ doesFileExist jfile)
( return (Just (AppendableJournalFile (jd, jfile)))
, return Nothing
)
-}
appendJournalFile :: Journalable content => JournalLocked -> AppendableJournalFile -> content -> Annex ()
appendJournalFile _jl (AppendableJournalFile (jd, jfile)) content = do
- let write = liftIO $ F.withFile (toOsPath jfile) ReadWriteMode $ \h -> do
+ let write = liftIO $ F.withFile jfile ReadWriteMode $ \h -> do
sz <- hFileSize h
when (sz /= 0) $ do
hSeek h SeekFromEnd (-1)
-- information that were made after that journal file was written.
{- Gets any journalled content for a file in the branch. -}
-getJournalFile :: JournalLocked -> GetPrivate -> RawFilePath -> Annex JournalledContent
+getJournalFile :: JournalLocked -> GetPrivate -> OsPath -> Annex JournalledContent
getJournalFile _jl = getJournalFileStale
data GetPrivate = GetPrivate Bool
- (or is in progress when this is called), if the file content does not end
- with a newline, it is truncated back to the previous newline.
-}
-getJournalFileStale :: GetPrivate -> RawFilePath -> Annex JournalledContent
+getJournalFileStale :: GetPrivate -> OsPath -> Annex JournalledContent
getJournalFileStale (GetPrivate getprivate) file = do
st <- Annex.getState id
let repo = Annex.repo st
jfile = journalFile file
getfrom d = catchMaybeIO $
discardIncompleteAppend . L.fromStrict
- <$> F.readFile' (toOsPath (d P.</> jfile))
+ <$> F.readFile' (d </> jfile)
-- Note that this forces read of the whole lazy bytestring.
discardIncompleteAppend :: L.ByteString -> L.ByteString
{- List of existing journal files in a journal directory, but without locking,
- may miss new ones just being added, or may have false positives if the
- journal is staged as it is run. -}
-getJournalledFilesStale :: (BranchState -> Git.Repo -> RawFilePath) -> Annex [RawFilePath]
+getJournalledFilesStale :: (BranchState -> Git.Repo -> OsPath) -> Annex [OsPath]
getJournalledFilesStale getjournaldir = do
bs <- getState
repo <- Annex.gitRepo
let d = getjournaldir bs repo
fs <- liftIO $ catchDefaultIO [] $
- getDirectoryContents (fromRawFilePath d)
- return $ filter (`notElem` [".", ".."]) $
- map (fileJournal . toRawFilePath) fs
+ getDirectoryContents d
+ return $ filter (`notElem` dirCruft) $
+ map fileJournal fs
{- Directory handle open on a journal directory. -}
-withJournalHandle :: (BranchState -> Git.Repo -> RawFilePath) -> (DirectoryHandle -> IO a) -> Annex a
+withJournalHandle :: (BranchState -> Git.Repo -> OsPath) -> (DirectoryHandle -> IO a) -> Annex a
withJournalHandle getjournaldir a = do
bs <- getState
repo <- Annex.gitRepo
where
-- avoid overhead of creating the journal directory when it already
-- exists
- opendir d = liftIO (openDirectory d)
+ opendir d = liftIO (openDirectory (fromOsPath d))
`catchIO` (const (createAnnexDirectory d >> opendir d))
{- Checks if there are changes in the journal. -}
-journalDirty :: (BranchState -> Git.Repo -> RawFilePath) -> Annex Bool
+journalDirty :: (BranchState -> Git.Repo -> OsPath) -> Annex Bool
journalDirty getjournaldir = do
st <- getState
d <- fromRepo (getjournaldir st)
- liftIO $ isDirectoryPopulated d
+ liftIO $ isDirectoryPopulated (fromOsPath d)
{- Produces a filename to use in the journal for a file on the branch.
- The filename does not include the journal directory.
- used in the branch is not necessary, and all the files are put directly
- in the journal directory.
-}
-journalFile :: RawFilePath -> RawFilePath
-journalFile file = B.concatMap mangle file
+journalFile :: OsPath -> OsPath
+journalFile file = OS.concat $ map mangle $ OS.unpack file
where
mangle c
- | P.isPathSeparator c = B.singleton underscore
- | c == underscore = B.pack [underscore, underscore]
- | otherwise = B.singleton c
- underscore = fromIntegral (ord '_')
+ | isPathSeparator c = OS.singleton underscore
+ | c == underscore = OS.pack [underscore, underscore]
+ | otherwise = OS.singleton c
+ underscore = unsafeFromChar '_'
{- Converts a journal file (relative to the journal dir) back to the
- filename on the branch. -}
-fileJournal :: RawFilePath -> RawFilePath
+fileJournal :: OsPath -> OsPath
fileJournal = go
where
go b =
- let (h, t) = B.break (== underscore) b
- in h <> case B.uncons t of
+ let (h, t) = OS.break (== underscore) b
+ in h <> case OS.uncons t of
Nothing -> t
- Just (_u, t') -> case B.uncons t' of
+ Just (_u, t') -> case OS.uncons t' of
Nothing -> t'
Just (w, t'')
| w == underscore ->
- B.cons underscore (go t'')
+ OS.cons underscore (go t'')
| otherwise ->
- B.cons P.pathSeparator (go t')
+ OS.cons pathSeparator (go t')
- underscore = fromIntegral (ord '_')
+ underscore = unsafeFromChar '_'
{- Sentinal value, only produced by lockJournal; required
- as a parameter by things that need to ensure the journal is
import qualified Database.Keys.Handle
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
+import qualified Utility.OsString as OS
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
-import qualified System.FilePath.ByteString as P
#ifndef mingw32_HOST_OS
#if MIN_VERSION_unix(2,8,0)
#else
type LinkTarget = S.ByteString
{- Checks if a file is a link to a key. -}
-isAnnexLink :: RawFilePath -> Annex (Maybe Key)
+isAnnexLink :: OsPath -> Annex (Maybe Key)
isAnnexLink file = maybe Nothing parseLinkTargetOrPointer <$> getAnnexLinkTarget file
{- Gets the link target of a symlink.
- Returns Nothing if the file is not a symlink, or not a link to annex
- content.
-}
-getAnnexLinkTarget :: RawFilePath -> Annex (Maybe LinkTarget)
+getAnnexLinkTarget :: OsPath -> Annex (Maybe LinkTarget)
getAnnexLinkTarget f = getAnnexLinkTarget' f
=<< (coreSymlinks <$> Annex.getGitConfig)
{- Pass False to force looking inside file, for when git checks out
- symlinks as plain files. -}
-getAnnexLinkTarget' :: RawFilePath -> Bool -> Annex (Maybe S.ByteString)
+getAnnexLinkTarget' :: OsPath -> Bool -> Annex (Maybe LinkTarget)
getAnnexLinkTarget' file coresymlinks = if coresymlinks
then check probesymlink $
return Nothing
| otherwise -> return Nothing
Nothing -> fallback
- probesymlink = R.readSymbolicLink file
+ probesymlink = R.readSymbolicLink (fromOsPath file)
- probefilecontent = F.withFile (toOsPath file) ReadMode $ \h -> do
+ probefilecontent = F.withFile file ReadMode $ \h -> do
s <- S.hGet h maxSymlinkSz
-- If we got the full amount, the file is too large
-- to be a symlink target.
then mempty
else s
-makeAnnexLink :: LinkTarget -> RawFilePath -> Annex ()
+makeAnnexLink :: LinkTarget -> OsPath -> Annex ()
makeAnnexLink = makeGitLink
{- Creates a link on disk.
- it's staged as such, so use addAnnexLink when adding a new file or
- modified link to git.
-}
-makeGitLink :: LinkTarget -> RawFilePath -> Annex ()
+makeGitLink :: LinkTarget -> OsPath -> Annex ()
makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
( liftIO $ do
- void $ tryIO $ R.removeLink file
- R.createSymbolicLink linktarget file
- , liftIO $ F.writeFile' (toOsPath file) linktarget
+ void $ tryIO $ R.removeLink file'
+ R.createSymbolicLink linktarget file'
+ , liftIO $ F.writeFile' file linktarget
)
+ where
+ file' = fromOsPath file
{- Creates a link on disk, and additionally stages it in git. -}
-addAnnexLink :: LinkTarget -> RawFilePath -> Annex ()
+addAnnexLink :: LinkTarget -> OsPath -> Annex ()
addAnnexLink linktarget file = do
makeAnnexLink linktarget file
stageSymlink file =<< hashSymlink linktarget
{- Injects a symlink target into git, returning its Sha. -}
hashSymlink :: LinkTarget -> Annex Sha
-hashSymlink = hashBlob . toInternalGitPath
+hashSymlink = go . fromOsPath . toInternalGitPath . toOsPath
+ where
+ go :: LinkTarget -> Annex Sha
+ go = hashBlob
{- Stages a symlink to an annexed object, using a Sha of its target. -}
-stageSymlink :: RawFilePath -> Sha -> Annex ()
+stageSymlink :: OsPath -> Sha -> Annex ()
stageSymlink file sha =
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.stageSymlink file sha)
hashPointerFile key = hashBlob $ formatPointer key
{- Stages a pointer file, using a Sha of its content -}
-stagePointerFile :: RawFilePath -> Maybe FileMode -> Sha -> Annex ()
+stagePointerFile :: OsPath -> Maybe FileMode -> Sha -> Annex ()
stagePointerFile file mode sha =
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.stageFile sha treeitemtype file)
| maybe False isExecutable mode = TreeExecutable
| otherwise = TreeFile
-writePointerFile :: RawFilePath -> Key -> Maybe FileMode -> IO ()
+writePointerFile :: OsPath -> Key -> Maybe FileMode -> IO ()
writePointerFile file k mode = do
- F.writeFile' (toOsPath file) (formatPointer k)
- maybe noop (R.setFileMode file) mode
+ F.writeFile' file (formatPointer k)
+ maybe noop (R.setFileMode (fromOsPath file)) mode
newtype Restage = Restage Bool
- if the process is interrupted before the git queue is fulushed, the
- restage will be taken care of later.
-}
-restagePointerFile :: Restage -> RawFilePath -> InodeCache -> Annex ()
+restagePointerFile :: Restage -> OsPath -> InodeCache -> Annex ()
restagePointerFile (Restage False) f orig = do
flip writeRestageLog orig =<< inRepo (toTopFilePath f)
toplevelWarning True $ unableToRestage $ Just f
=<< Annex.getRead Annex.keysdbhandle
realindex <- liftIO $ Git.Index.currentIndexFile r
numsz@(numfiles, _) <- calcnumsz
- let lock = fromRawFilePath (Git.Index.indexFileLock realindex)
+ let lock = Git.Index.indexFileLock realindex
lockindex = liftIO $ catchMaybeIO $ Git.LockFile.openLock' lock
unlockindex = liftIO . maybe noop Git.LockFile.closeLock
showwarning = warning $ unableToRestage Nothing
go Nothing = showwarning
go (Just _) = withtmpdir $ \tmpdir -> do
tsd <- getTSDelta
- let tmpindex = toRawFilePath (tmpdir </> "index")
+ let tmpindex = tmpdir </> literalOsPath "index"
let replaceindex = liftIO $ moveFile tmpindex realindex
let updatetmpindex = do
r' <- liftIO $ Git.Env.addGitEnv r Git.Index.indexEnv
+ . fromOsPath
=<< Git.Index.indexEnvVal tmpindex
configfilterprocess numsz $
runupdateindex tsd r' replaceindex
bracket lockindex unlockindex go
where
withtmpdir = withTmpDirIn
- (fromRawFilePath $ Git.localGitDir r)
- (toOsPath "annexindex")
+ (Git.localGitDir r)
+ (literalOsPath "annexindex")
isunmodified tsd f orig =
genInodeCache f tsd >>= return . \case
ck = ConfigKey "filter.annex.process"
ckd = ConfigKey "filter.annex.process-temp-disabled"
-unableToRestage :: Maybe RawFilePath -> StringContainingQuotedPath
+unableToRestage :: Maybe OsPath -> StringContainingQuotedPath
unableToRestage mf =
"git status will show " <> maybe "some files" QuotedPath mf
<> " to be modified, since content availability has changed"
Nothing -> Right Nothing
where
parsekey l
- | isLinkToAnnex l = fileKey $ snd $ S8.breakEnd pathsep l
+ | isLinkToAnnex l = fileKey $ toOsPath $
+ snd $ S8.breakEnd pathsep l
| otherwise = Nothing
restvalid r
in parseLinkTargetOrPointer' (L.toStrict b')
formatPointer :: Key -> S.ByteString
-formatPointer k = prefix <> keyFile k <> nl
+formatPointer k = fromOsPath prefix <> fromOsPath (keyFile k) <> nl
where
- prefix = toInternalGitPath $ P.pathSeparator `S.cons` objectDir
+ prefix = toInternalGitPath $ pathSeparator `OS.cons` objectDir
nl = S8.singleton '\n'
{- Maximum size of a file that could be a pointer to a key.
- an object that looks like a pointer file. Or that a non-annex
- symlink does. Avoids a false positive in those cases.
- -}
-isPointerFile :: RawFilePath -> IO (Maybe Key)
+isPointerFile :: OsPath -> IO (Maybe Key)
isPointerFile f = catchDefaultIO Nothing $
#if defined(mingw32_HOST_OS)
- F.withFile (toOsPath f) ReadMode readhandle
+ F.withFile f ReadMode readhandle
#else
#if MIN_VERSION_unix(2,8,0)
let open = do
- fd <- openFd (fromRawFilePath f) ReadOnly
+ fd <- openFd (fromOsPath f) ReadOnly
(defaultFileFlags { nofollow = True })
fdToHandle fd
in bracket open hClose readhandle
#else
- ifM (isSymbolicLink <$> R.getSymbolicLinkStatus f)
+ ifM (isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath f))
( return Nothing
- , F.withFile (toOsPath f) ReadMode readhandle
+ , F.withFile f ReadMode readhandle
)
#endif
#endif
- than .git to be used.
-}
isLinkToAnnex :: S.ByteString -> Bool
-isLinkToAnnex s = p `S.isInfixOf` s
+isLinkToAnnex s = p `OS.isInfixOf` (toOsPath s)
#ifdef mingw32_HOST_OS
-- '/' is used inside pointer files on Windows, not the native '\'
- || p' `S.isInfixOf` s
+ || p' `OS.isInfixOf` s
#endif
where
- p = P.pathSeparator `S.cons` objectDir
+ p = pathSeparator `OS.cons` objectDir
#ifdef mingw32_HOST_OS
p' = toInternalGitPath p
#endif
import Data.Default
import qualified Data.List.NonEmpty as NE
import qualified Data.ByteString.Char8 as S8
-import qualified System.FilePath.ByteString as P
+import qualified Data.ByteString.Short as SB
import Common
import Key
import Git.FilePath
import Annex.DirHashes
import Annex.Fixup
-import qualified Utility.RawFilePath as R
{- Conventions:
-
{- The directory git annex uses for local state, relative to the .git
- directory -}
-annexDir :: RawFilePath
-annexDir = P.addTrailingPathSeparator "annex"
+annexDir :: OsPath
+annexDir = addTrailingPathSeparator (literalOsPath "annex")
{- The directory git annex uses for locally available object content,
- relative to the .git directory -}
-objectDir :: RawFilePath
-objectDir = P.addTrailingPathSeparator $ annexDir P.</> "objects"
+objectDir :: OsPath
+objectDir = addTrailingPathSeparator $ annexDir </> literalOsPath "objects"
{- Annexed file's possible locations relative to the .git directory
- in a non-bare eepository.
- Normally it is hashDirMixed. However, it's always possible that a
- bare repository was converted to non-bare, or that the cripped
- filesystem setting changed, so still need to check both. -}
-annexLocationsNonBare :: GitConfig -> Key -> [RawFilePath]
+annexLocationsNonBare :: GitConfig -> Key -> [OsPath]
annexLocationsNonBare config key =
map (annexLocation config key) [hashDirMixed, hashDirLower]
{- Annexed file's possible locations relative to a bare repository. -}
-annexLocationsBare :: GitConfig -> Key -> [RawFilePath]
+annexLocationsBare :: GitConfig -> Key -> [OsPath]
annexLocationsBare config key =
map (annexLocation config key) [hashDirLower, hashDirMixed]
-annexLocation :: GitConfig -> Key -> (HashLevels -> Hasher) -> RawFilePath
-annexLocation config key hasher = objectDir P.</> keyPath key (hasher $ objectHashLevels config)
+annexLocation :: GitConfig -> Key -> (HashLevels -> Hasher) -> OsPath
+annexLocation config key hasher = objectDir </> keyPath key (hasher $ objectHashLevels config)
{- For exportree remotes with annexobjects=true, objects are stored
- in this location as well as in the exported tree. -}
exportAnnexObjectLocation :: GitConfig -> Key -> ExportLocation
exportAnnexObjectLocation gc k =
mkExportLocation $
- ".git" P.</> annexLocation gc k hashDirLower
+ literalOsPath ".git" </> annexLocation gc k hashDirLower
{- Number of subdirectories from the gitAnnexObjectDir
- to the gitAnnexLocation. -}
- When the file is not present, returns the location where the file should
- be stored.
-}
-gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO RawFilePath
-gitAnnexLocation = gitAnnexLocation' R.doesPathExist
+gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO OsPath
+gitAnnexLocation = gitAnnexLocation' doesPathExist
-gitAnnexLocation' :: (RawFilePath -> IO Bool) -> Key -> Git.Repo -> GitConfig -> IO RawFilePath
+gitAnnexLocation' :: (OsPath -> IO Bool) -> Key -> Git.Repo -> GitConfig -> IO OsPath
gitAnnexLocation' checker key r config = gitAnnexLocation'' key r config
(annexCrippledFileSystem config)
(coreSymlinks config)
checker
(Git.localGitDir r)
-gitAnnexLocation'' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (RawFilePath -> IO Bool) -> RawFilePath -> IO RawFilePath
+gitAnnexLocation'' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (OsPath -> IO Bool) -> OsPath -> IO OsPath
gitAnnexLocation'' key r config crippled symlinkssupported checker gitdir
{- Bare repositories default to hashDirLower for new
- content, as it's more portable. But check all locations. -}
only = return . inrepo . annexLocation config key
checkall f = check $ map inrepo $ f config key
- inrepo d = gitdir P.</> d
+ inrepo d = gitdir </> d
check locs@(l:_) = fromMaybe l <$> firstM checker locs
check [] = error "internal"
{- Calculates a symlink target to link a file to an annexed object. -}
-gitAnnexLink :: RawFilePath -> Key -> Git.Repo -> GitConfig -> IO RawFilePath
+gitAnnexLink :: OsPath -> Key -> Git.Repo -> GitConfig -> IO OsPath
gitAnnexLink file key r config = do
- currdir <- R.getCurrentDirectory
+ currdir <- getCurrentDirectory
let absfile = absNormPathUnix currdir file
let gitdir = getgitdir currdir
loc <- gitAnnexLocation'' key r config False False (\_ -> return True) gitdir
- supporting symlinks; generate link target that will
- work portably. -}
| not (coreSymlinks config) && needsSubmoduleFixup r =
- absNormPathUnix currdir (Git.repoPath r P.</> ".git")
+ absNormPathUnix currdir (Git.repoPath r </> literalOsPath ".git")
| otherwise = Git.localGitDir r
absNormPathUnix d p = toInternalGitPath $
absPathFrom (toInternalGitPath d) (toInternalGitPath p)
{- Calculates a symlink target as would be used in a typical git
- repository, with .git in the top of the work tree. -}
-gitAnnexLinkCanonical :: RawFilePath -> Key -> Git.Repo -> GitConfig -> IO RawFilePath
+gitAnnexLinkCanonical :: OsPath -> Key -> Git.Repo -> GitConfig -> IO OsPath
gitAnnexLinkCanonical file key r config = gitAnnexLink file key r' config'
where
r' = case r of
Git.Repo { Git.location = l@Git.Local { Git.worktree = Just wt } } ->
- r { Git.location = l { Git.gitdir = wt P.</> ".git" } }
+ r { Git.location = l { Git.gitdir = wt </> literalOsPath ".git" } }
_ -> r
config' = config
{ annexCrippledFileSystem = False
}
{- File used to lock a key's content. -}
-gitAnnexContentLock :: Key -> Git.Repo -> GitConfig -> IO RawFilePath
+gitAnnexContentLock :: Key -> Git.Repo -> GitConfig -> IO OsPath
gitAnnexContentLock key r config = do
loc <- gitAnnexLocation key r config
- return $ loc <> ".lck"
+ return $ loc <> literalOsPath ".lck"
{- File used to indicate a key's content should not be dropped until after
- a specified time. -}
-gitAnnexContentRetentionTimestamp :: Key -> Git.Repo -> GitConfig -> IO RawFilePath
+gitAnnexContentRetentionTimestamp :: Key -> Git.Repo -> GitConfig -> IO OsPath
gitAnnexContentRetentionTimestamp key r config = do
loc <- gitAnnexLocation key r config
- return $ loc <> ".rtm"
+ return $ loc <> literalOsPath ".rtm"
{- Lock file for gitAnnexContentRetentionTimestamp -}
-gitAnnexContentRetentionTimestampLock :: Key -> Git.Repo -> GitConfig -> IO RawFilePath
+gitAnnexContentRetentionTimestampLock :: Key -> Git.Repo -> GitConfig -> IO OsPath
gitAnnexContentRetentionTimestampLock key r config = do
loc <- gitAnnexLocation key r config
- return $ loc <> ".rtl"
+ return $ loc <> literalOsPath ".rtl"
{- Lock that is held when taking the gitAnnexContentLock to support the v10
- upgrade.
- is mounted read-only. The gitAnnexInodeSentinal is created by git-annex
- init, so should already exist.
-}
-gitAnnexContentLockLock :: Git.Repo -> RawFilePath
+gitAnnexContentLockLock :: Git.Repo -> OsPath
gitAnnexContentLockLock = gitAnnexInodeSentinal
-gitAnnexInodeSentinal :: Git.Repo -> RawFilePath
-gitAnnexInodeSentinal r = gitAnnexDir r P.</> "sentinal"
+gitAnnexInodeSentinal :: Git.Repo -> OsPath
+gitAnnexInodeSentinal r = gitAnnexDir r </> literalOsPath "sentinal"
-gitAnnexInodeSentinalCache :: Git.Repo -> RawFilePath
-gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r <> ".cache"
+gitAnnexInodeSentinalCache :: Git.Repo -> OsPath
+gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r <> literalOsPath ".cache"
{- The annex directory of a repository. -}
-gitAnnexDir :: Git.Repo -> RawFilePath
-gitAnnexDir r = P.addTrailingPathSeparator $ Git.localGitDir r P.</> annexDir
+gitAnnexDir :: Git.Repo -> OsPath
+gitAnnexDir r = addTrailingPathSeparator $ Git.localGitDir r </> annexDir
{- The part of the annex directory where file contents are stored. -}
-gitAnnexObjectDir :: Git.Repo -> RawFilePath
-gitAnnexObjectDir r = P.addTrailingPathSeparator $
- Git.localGitDir r P.</> objectDir
+gitAnnexObjectDir :: Git.Repo -> OsPath
+gitAnnexObjectDir r = addTrailingPathSeparator $
+ Git.localGitDir r </> objectDir
{- .git/annex/tmp/ is used for temp files for key's contents -}
-gitAnnexTmpObjectDir :: Git.Repo -> RawFilePath
-gitAnnexTmpObjectDir r = P.addTrailingPathSeparator $
- gitAnnexDir r P.</> "tmp"
+gitAnnexTmpObjectDir :: Git.Repo -> OsPath
+gitAnnexTmpObjectDir r = addTrailingPathSeparator $
+ gitAnnexDir r </> literalOsPath "tmp"
{- .git/annex/othertmp/ is used for other temp files -}
-gitAnnexTmpOtherDir :: Git.Repo -> RawFilePath
-gitAnnexTmpOtherDir r = P.addTrailingPathSeparator $
- gitAnnexDir r P.</> "othertmp"
+gitAnnexTmpOtherDir :: Git.Repo -> OsPath
+gitAnnexTmpOtherDir r = addTrailingPathSeparator $
+ gitAnnexDir r </> literalOsPath "othertmp"
{- Lock file for gitAnnexTmpOtherDir. -}
-gitAnnexTmpOtherLock :: Git.Repo -> RawFilePath
-gitAnnexTmpOtherLock r = gitAnnexDir r P.</> "othertmp.lck"
+gitAnnexTmpOtherLock :: Git.Repo -> OsPath
+gitAnnexTmpOtherLock r = gitAnnexDir r </> literalOsPath "othertmp.lck"
{- .git/annex/misctmp/ was used by old versions of git-annex and is still
- used during initialization -}
-gitAnnexTmpOtherDirOld :: Git.Repo -> RawFilePath
-gitAnnexTmpOtherDirOld r = P.addTrailingPathSeparator $
- gitAnnexDir r P.</> "misctmp"
+gitAnnexTmpOtherDirOld :: Git.Repo -> OsPath
+gitAnnexTmpOtherDirOld r = addTrailingPathSeparator $
+ gitAnnexDir r </> literalOsPath "misctmp"
{- .git/annex/watchtmp/ is used by the watcher and assistant -}
-gitAnnexTmpWatcherDir :: Git.Repo -> RawFilePath
-gitAnnexTmpWatcherDir r = P.addTrailingPathSeparator $
- gitAnnexDir r P.</> "watchtmp"
+gitAnnexTmpWatcherDir :: Git.Repo -> OsPath
+gitAnnexTmpWatcherDir r = addTrailingPathSeparator $
+ gitAnnexDir r </> literalOsPath "watchtmp"
{- The temp file to use for a given key's content. -}
-gitAnnexTmpObjectLocation :: Key -> Git.Repo -> RawFilePath
-gitAnnexTmpObjectLocation key r = gitAnnexTmpObjectDir r P.</> keyFile key
+gitAnnexTmpObjectLocation :: Key -> Git.Repo -> OsPath
+gitAnnexTmpObjectLocation key r = gitAnnexTmpObjectDir r </> keyFile key
{- Given a temp file such as gitAnnexTmpObjectLocation, makes a name for a
- subdirectory in the same location, that can be used as a work area
- There are ordering requirements for creating these directories;
- use Annex.Content.withTmpWorkDir to set them up.
-}
-gitAnnexTmpWorkDir :: RawFilePath -> RawFilePath
+gitAnnexTmpWorkDir :: OsPath -> OsPath
gitAnnexTmpWorkDir p =
- let (dir, f) = P.splitFileName p
+ let (dir, f) = splitFileName p
-- Using a prefix avoids name conflict with any other keys.
- in dir P.</> "work." <> f
+ in dir </> literalOsPath "work." <> f
{- .git/annex/bad/ is used for bad files found during fsck -}
-gitAnnexBadDir :: Git.Repo -> RawFilePath
-gitAnnexBadDir r = P.addTrailingPathSeparator $ gitAnnexDir r P.</> "bad"
+gitAnnexBadDir :: Git.Repo -> OsPath
+gitAnnexBadDir r = addTrailingPathSeparator $
+ gitAnnexDir r </> literalOsPath "bad"
{- The bad file to use for a given key. -}
-gitAnnexBadLocation :: Key -> Git.Repo -> RawFilePath
-gitAnnexBadLocation key r = gitAnnexBadDir r P.</> keyFile key
+gitAnnexBadLocation :: Key -> Git.Repo -> OsPath
+gitAnnexBadLocation key r = gitAnnexBadDir r </> keyFile key
{- .git/annex/foounused is used to number possibly unused keys -}
-gitAnnexUnusedLog :: RawFilePath -> Git.Repo -> RawFilePath
-gitAnnexUnusedLog prefix r = gitAnnexDir r P.</> (prefix <> "unused")
+gitAnnexUnusedLog :: OsPath -> Git.Repo -> OsPath
+gitAnnexUnusedLog prefix r =
+ gitAnnexDir r </> (prefix <> literalOsPath "unused")
{- .git/annex/keysdb/ contains a database of information about keys. -}
-gitAnnexKeysDbDir :: Git.Repo -> GitConfig -> RawFilePath
-gitAnnexKeysDbDir r c = fromMaybe (gitAnnexDir r) (annexDbDir c) P.</> "keysdb"
+gitAnnexKeysDbDir :: Git.Repo -> GitConfig -> OsPath
+gitAnnexKeysDbDir r c =
+ fromMaybe (gitAnnexDir r) (annexDbDir c) </> literalOsPath "keysdb"
{- Lock file for the keys database. -}
-gitAnnexKeysDbLock :: Git.Repo -> GitConfig -> RawFilePath
-gitAnnexKeysDbLock r c = gitAnnexKeysDbDir r c <> ".lck"
+gitAnnexKeysDbLock :: Git.Repo -> GitConfig -> OsPath
+gitAnnexKeysDbLock r c = gitAnnexKeysDbDir r c <> literalOsPath ".lck"
{- Contains the stat of the last index file that was
- reconciled with the keys database. -}
-gitAnnexKeysDbIndexCache :: Git.Repo -> GitConfig -> RawFilePath
-gitAnnexKeysDbIndexCache r c = gitAnnexKeysDbDir r c <> ".cache"
+gitAnnexKeysDbIndexCache :: Git.Repo -> GitConfig -> OsPath
+gitAnnexKeysDbIndexCache r c =
+ gitAnnexKeysDbDir r c <> literalOsPath ".cache"
{- .git/annex/fsck/uuid/ is used to store information about incremental
- fscks. -}
-gitAnnexFsckDir :: UUID -> Git.Repo -> Maybe GitConfig -> RawFilePath
+gitAnnexFsckDir :: UUID -> Git.Repo -> Maybe GitConfig -> OsPath
gitAnnexFsckDir u r mc = case annexDbDir =<< mc of
Nothing -> go (gitAnnexDir r)
Just d -> go d
where
- go d = d P.</> "fsck" P.</> fromUUID u
+ go d = d </> literalOsPath "fsck" </> fromUUID u
{- used to store information about incremental fscks. -}
-gitAnnexFsckState :: UUID -> Git.Repo -> RawFilePath
-gitAnnexFsckState u r = gitAnnexFsckDir u r Nothing P.</> "state"
+gitAnnexFsckState :: UUID -> Git.Repo -> OsPath
+gitAnnexFsckState u r = gitAnnexFsckDir u r Nothing </> literalOsPath "state"
{- Directory containing database used to record fsck info. -}
-gitAnnexFsckDbDir :: UUID -> Git.Repo -> GitConfig -> RawFilePath
-gitAnnexFsckDbDir u r c = gitAnnexFsckDir u r (Just c) P.</> "fsckdb"
+gitAnnexFsckDbDir :: UUID -> Git.Repo -> GitConfig -> OsPath
+gitAnnexFsckDbDir u r c = gitAnnexFsckDir u r (Just c) </> literalOsPath "fsckdb"
{- Directory containing old database used to record fsck info. -}
-gitAnnexFsckDbDirOld :: UUID -> Git.Repo -> GitConfig -> RawFilePath
-gitAnnexFsckDbDirOld u r c = gitAnnexFsckDir u r (Just c) P.</> "db"
+gitAnnexFsckDbDirOld :: UUID -> Git.Repo -> GitConfig -> OsPath
+gitAnnexFsckDbDirOld u r c = gitAnnexFsckDir u r (Just c) </> literalOsPath "db"
{- Lock file for the fsck database. -}
-gitAnnexFsckDbLock :: UUID -> Git.Repo -> GitConfig -> RawFilePath
-gitAnnexFsckDbLock u r c = gitAnnexFsckDir u r (Just c) P.</> "fsck.lck"
+gitAnnexFsckDbLock :: UUID -> Git.Repo -> GitConfig -> OsPath
+gitAnnexFsckDbLock u r c = gitAnnexFsckDir u r (Just c) </> literalOsPath "fsck.lck"
{- .git/annex/fsckresults/uuid is used to store results of git fscks -}
-gitAnnexFsckResultsLog :: UUID -> Git.Repo -> RawFilePath
+gitAnnexFsckResultsLog :: UUID -> Git.Repo -> OsPath
gitAnnexFsckResultsLog u r =
- gitAnnexDir r P.</> "fsckresults" P.</> fromUUID u
+ gitAnnexDir r </> literalOsPath "fsckresults" </> fromUUID u
{- .git/annex/upgrade.log is used to record repository version upgrades. -}
-gitAnnexUpgradeLog :: Git.Repo -> RawFilePath
-gitAnnexUpgradeLog r = gitAnnexDir r P.</> "upgrade.log"
+gitAnnexUpgradeLog :: Git.Repo -> OsPath
+gitAnnexUpgradeLog r = gitAnnexDir r </> literalOsPath "upgrade.log"
-gitAnnexUpgradeLock :: Git.Repo -> RawFilePath
-gitAnnexUpgradeLock r = gitAnnexDir r P.</> "upgrade.lck"
+gitAnnexUpgradeLock :: Git.Repo -> OsPath
+gitAnnexUpgradeLock r = gitAnnexDir r </> literalOsPath "upgrade.lck"
{- .git/annex/smudge.log is used to log smudged worktree files that need to
- be updated. -}
-gitAnnexSmudgeLog :: Git.Repo -> RawFilePath
-gitAnnexSmudgeLog r = gitAnnexDir r P.</> "smudge.log"
+gitAnnexSmudgeLog :: Git.Repo -> OsPath
+gitAnnexSmudgeLog r = gitAnnexDir r </> literalOsPath "smudge.log"
-gitAnnexSmudgeLock :: Git.Repo -> RawFilePath
-gitAnnexSmudgeLock r = gitAnnexDir r P.</> "smudge.lck"
+gitAnnexSmudgeLock :: Git.Repo -> OsPath
+gitAnnexSmudgeLock r = gitAnnexDir r </> literalOsPath "smudge.lck"
{- .git/annex/restage.log is used to log worktree files that need to be
- restaged in git -}
-gitAnnexRestageLog :: Git.Repo -> RawFilePath
-gitAnnexRestageLog r = gitAnnexDir r P.</> "restage.log"
+gitAnnexRestageLog :: Git.Repo -> OsPath
+gitAnnexRestageLog r = gitAnnexDir r </> literalOsPath "restage.log"
{- .git/annex/restage.old is used while restaging files in git -}
-gitAnnexRestageLogOld :: Git.Repo -> RawFilePath
-gitAnnexRestageLogOld r = gitAnnexDir r P.</> "restage.old"
+gitAnnexRestageLogOld :: Git.Repo -> OsPath
+gitAnnexRestageLogOld r = gitAnnexDir r </> literalOsPath "restage.old"
-gitAnnexRestageLock :: Git.Repo -> RawFilePath
-gitAnnexRestageLock r = gitAnnexDir r P.</> "restage.lck"
+gitAnnexRestageLock :: Git.Repo -> OsPath
+gitAnnexRestageLock r = gitAnnexDir r </> literalOsPath "restage.lck"
{- .git/annex/adjust.log is used to log when the adjusted branch needs to
- be updated. -}
-gitAnnexAdjustedBranchUpdateLog :: Git.Repo -> RawFilePath
-gitAnnexAdjustedBranchUpdateLog r = gitAnnexDir r P.</> "adjust.log"
+gitAnnexAdjustedBranchUpdateLog :: Git.Repo -> OsPath
+gitAnnexAdjustedBranchUpdateLog r = gitAnnexDir r </> literalOsPath "adjust.log"
-gitAnnexAdjustedBranchUpdateLock :: Git.Repo -> RawFilePath
-gitAnnexAdjustedBranchUpdateLock r = gitAnnexDir r P.</> "adjust.lck"
+gitAnnexAdjustedBranchUpdateLock :: Git.Repo -> OsPath
+gitAnnexAdjustedBranchUpdateLock r = gitAnnexDir r </> literalOsPath "adjust.lck"
{- .git/annex/migrate.log is used to log migrations before committing them. -}
-gitAnnexMigrateLog :: Git.Repo -> RawFilePath
-gitAnnexMigrateLog r = gitAnnexDir r P.</> "migrate.log"
+gitAnnexMigrateLog :: Git.Repo -> OsPath
+gitAnnexMigrateLog r = gitAnnexDir r </> literalOsPath "migrate.log"
-gitAnnexMigrateLock :: Git.Repo -> RawFilePath
-gitAnnexMigrateLock r = gitAnnexDir r P.</> "migrate.lck"
+gitAnnexMigrateLock :: Git.Repo -> OsPath
+gitAnnexMigrateLock r = gitAnnexDir r </> literalOsPath "migrate.lck"
{- .git/annex/migrations.log is used to log committed migrations. -}
-gitAnnexMigrationsLog :: Git.Repo -> RawFilePath
-gitAnnexMigrationsLog r = gitAnnexDir r P.</> "migrations.log"
+gitAnnexMigrationsLog :: Git.Repo -> OsPath
+gitAnnexMigrationsLog r = gitAnnexDir r </> literalOsPath "migrations.log"
-gitAnnexMigrationsLock :: Git.Repo -> RawFilePath
-gitAnnexMigrationsLock r = gitAnnexDir r P.</> "migrations.lck"
+gitAnnexMigrationsLock :: Git.Repo -> OsPath
+gitAnnexMigrationsLock r = gitAnnexDir r </> literalOsPath "migrations.lck"
{- .git/annex/move.log is used to log moves that are in progress,
- to better support resuming an interrupted move. -}
-gitAnnexMoveLog :: Git.Repo -> RawFilePath
-gitAnnexMoveLog r = gitAnnexDir r P.</> "move.log"
+gitAnnexMoveLog :: Git.Repo -> OsPath
+gitAnnexMoveLog r = gitAnnexDir r </> literalOsPath "move.log"
-gitAnnexMoveLock :: Git.Repo -> RawFilePath
-gitAnnexMoveLock r = gitAnnexDir r P.</> "move.lck"
+gitAnnexMoveLock :: Git.Repo -> OsPath
+gitAnnexMoveLock r = gitAnnexDir r </> literalOsPath "move.lck"
{- .git/annex/export/ is used to store information about
- exports to special remotes. -}
-gitAnnexExportDir :: Git.Repo -> GitConfig -> RawFilePath
-gitAnnexExportDir r c = fromMaybe (gitAnnexDir r) (annexDbDir c) P.</> "export"
+gitAnnexExportDir :: Git.Repo -> GitConfig -> OsPath
+gitAnnexExportDir r c = fromMaybe (gitAnnexDir r) (annexDbDir c)
+ </> literalOsPath "export"
{- Directory containing database used to record export info. -}
-gitAnnexExportDbDir :: UUID -> Git.Repo -> GitConfig -> RawFilePath
+gitAnnexExportDbDir :: UUID -> Git.Repo -> GitConfig -> OsPath
gitAnnexExportDbDir u r c =
- gitAnnexExportDir r c P.</> fromUUID u P.</> "exportdb"
+ gitAnnexExportDir r c </> fromUUID u </> literalOsPath "exportdb"
{- Lock file for export database. -}
-gitAnnexExportLock :: UUID -> Git.Repo -> GitConfig -> RawFilePath
-gitAnnexExportLock u r c = gitAnnexExportDbDir u r c <> ".lck"
+gitAnnexExportLock :: UUID -> Git.Repo -> GitConfig -> OsPath
+gitAnnexExportLock u r c = gitAnnexExportDbDir u r c <> literalOsPath ".lck"
{- Lock file for updating the export database with information from the
- repository. -}
-gitAnnexExportUpdateLock :: UUID -> Git.Repo -> GitConfig -> RawFilePath
-gitAnnexExportUpdateLock u r c = gitAnnexExportDbDir u r c <> ".upl"
+gitAnnexExportUpdateLock :: UUID -> Git.Repo -> GitConfig -> OsPath
+gitAnnexExportUpdateLock u r c = gitAnnexExportDbDir u r c <> literalOsPath ".upl"
{- Log file used to keep track of files that were in the tree exported to a
- remote, but were excluded by its preferred content settings. -}
-gitAnnexExportExcludeLog :: UUID -> Git.Repo -> RawFilePath
-gitAnnexExportExcludeLog u r = gitAnnexDir r P.</> "export.ex" P.</> fromUUID u
+gitAnnexExportExcludeLog :: UUID -> Git.Repo -> OsPath
+gitAnnexExportExcludeLog u r = gitAnnexDir r
+ </> literalOsPath "export.ex" </> fromUUID u
{- Directory containing database used to record remote content ids.
-
- (This used to be "cid", but a problem with the database caused it to
- need to be rebuilt with a new name.)
-}
-gitAnnexContentIdentifierDbDir :: Git.Repo -> GitConfig -> RawFilePath
+gitAnnexContentIdentifierDbDir :: Git.Repo -> GitConfig -> OsPath
gitAnnexContentIdentifierDbDir r c =
- fromMaybe (gitAnnexDir r) (annexDbDir c) P.</> "cidsdb"
+ fromMaybe (gitAnnexDir r) (annexDbDir c) </> literalOsPath "cidsdb"
{- Lock file for writing to the content id database. -}
-gitAnnexContentIdentifierLock :: Git.Repo -> GitConfig -> RawFilePath
-gitAnnexContentIdentifierLock r c = gitAnnexContentIdentifierDbDir r c <> ".lck"
+gitAnnexContentIdentifierLock :: Git.Repo -> GitConfig -> OsPath
+gitAnnexContentIdentifierLock r c =
+ gitAnnexContentIdentifierDbDir r c <> literalOsPath ".lck"
{- .git/annex/import/ is used to store information about
- imports from special remotes. -}
-gitAnnexImportDir :: Git.Repo -> GitConfig -> RawFilePath
-gitAnnexImportDir r c = fromMaybe (gitAnnexDir r) (annexDbDir c) P.</> "import"
+gitAnnexImportDir :: Git.Repo -> GitConfig -> OsPath
+gitAnnexImportDir r c =
+ fromMaybe (gitAnnexDir r) (annexDbDir c) </> literalOsPath "import"
{- File containing state about the last import done from a remote. -}
-gitAnnexImportLog :: UUID -> Git.Repo -> GitConfig -> RawFilePath
-gitAnnexImportLog u r c =
- gitAnnexImportDir r c P.</> fromUUID u P.</> "log"
+gitAnnexImportLog :: UUID -> Git.Repo -> GitConfig -> OsPath
+gitAnnexImportLog u r c =
+ gitAnnexImportDir r c </> fromUUID u </> literalOsPath "log"
{- Directory containing database used by importfeed. -}
-gitAnnexImportFeedDbDir :: Git.Repo -> GitConfig -> RawFilePath
+gitAnnexImportFeedDbDir :: Git.Repo -> GitConfig -> OsPath
gitAnnexImportFeedDbDir r c =
- fromMaybe (gitAnnexDir r) (annexDbDir c) P.</> "importfeed"
+ fromMaybe (gitAnnexDir r) (annexDbDir c) </> literalOsPath "importfeed"
{- Lock file for writing to the importfeed database. -}
-gitAnnexImportFeedDbLock :: Git.Repo -> GitConfig -> RawFilePath
-gitAnnexImportFeedDbLock r c = gitAnnexImportFeedDbDir r c <> ".lck"
+gitAnnexImportFeedDbLock :: Git.Repo -> GitConfig -> OsPath
+gitAnnexImportFeedDbLock r c =
+ gitAnnexImportFeedDbDir r c <> literalOsPath ".lck"
{- Directory containing reposize database. -}
-gitAnnexRepoSizeDbDir :: Git.Repo -> GitConfig -> RawFilePath
+gitAnnexRepoSizeDbDir :: Git.Repo -> GitConfig -> OsPath
gitAnnexRepoSizeDbDir r c =
- fromMaybe (gitAnnexDir r) (annexDbDir c) P.</> "reposize" P.</> "db"
+ fromMaybe (gitAnnexDir r) (annexDbDir c) </> literalOsPath "reposize" </> literalOsPath "db"
{- Lock file for the reposize database. -}
-gitAnnexRepoSizeDbLock :: Git.Repo -> GitConfig -> RawFilePath
+gitAnnexRepoSizeDbLock :: Git.Repo -> GitConfig -> OsPath
gitAnnexRepoSizeDbLock r c =
- fromMaybe (gitAnnexDir r) (annexDbDir c) P.</> "reposize" P.</> "lock"
+ fromMaybe (gitAnnexDir r) (annexDbDir c) </> literalOsPath "reposize" </> literalOsPath "lock"
{- Directory containing liveness pid files. -}
-gitAnnexRepoSizeLiveDir :: Git.Repo -> GitConfig -> RawFilePath
+gitAnnexRepoSizeLiveDir :: Git.Repo -> GitConfig -> OsPath
gitAnnexRepoSizeLiveDir r c =
- fromMaybe (gitAnnexDir r) (annexDbDir c) P.</> "reposize" P.</> "live"
+ fromMaybe (gitAnnexDir r) (annexDbDir c) </> literalOsPath "reposize" </> literalOsPath "live"
{- .git/annex/schedulestate is used to store information about when
- scheduled jobs were last run. -}
-gitAnnexScheduleState :: Git.Repo -> RawFilePath
-gitAnnexScheduleState r = gitAnnexDir r P.</> "schedulestate"
+gitAnnexScheduleState :: Git.Repo -> OsPath
+gitAnnexScheduleState r = gitAnnexDir r </> literalOsPath "schedulestate"
{- .git/annex/creds/ is used to store credentials to access some special
- remotes. -}
-gitAnnexCredsDir :: Git.Repo -> RawFilePath
-gitAnnexCredsDir r = P.addTrailingPathSeparator $ gitAnnexDir r P.</> "creds"
+gitAnnexCredsDir :: Git.Repo -> OsPath
+gitAnnexCredsDir r = addTrailingPathSeparator $
+ gitAnnexDir r </> literalOsPath "creds"
{- .git/annex/certificate.pem and .git/annex/key.pem are used by the webapp
- when HTTPS is enabled -}
-gitAnnexWebCertificate :: Git.Repo -> FilePath
-gitAnnexWebCertificate r = fromRawFilePath $ gitAnnexDir r P.</> "certificate.pem"
-gitAnnexWebPrivKey :: Git.Repo -> FilePath
-gitAnnexWebPrivKey r = fromRawFilePath $ gitAnnexDir r P.</> "privkey.pem"
+gitAnnexWebCertificate :: Git.Repo -> OsPath
+gitAnnexWebCertificate r = gitAnnexDir r </> literalOsPath "certificate.pem"
+gitAnnexWebPrivKey :: Git.Repo -> OsPath
+gitAnnexWebPrivKey r = gitAnnexDir r </> literalOsPath "privkey.pem"
{- .git/annex/feeds/ is used to record per-key (url) state by importfeed -}
-gitAnnexFeedStateDir :: Git.Repo -> RawFilePath
-gitAnnexFeedStateDir r = P.addTrailingPathSeparator $
- gitAnnexDir r P.</> "feedstate"
+gitAnnexFeedStateDir :: Git.Repo -> OsPath
+gitAnnexFeedStateDir r = addTrailingPathSeparator $
+ gitAnnexDir r </> literalOsPath "feedstate"
-gitAnnexFeedState :: Key -> Git.Repo -> RawFilePath
-gitAnnexFeedState k r = gitAnnexFeedStateDir r P.</> keyFile k
+gitAnnexFeedState :: Key -> Git.Repo -> OsPath
+gitAnnexFeedState k r = gitAnnexFeedStateDir r </> keyFile k
{- .git/annex/merge/ is used as a empty work tree for merges in
- adjusted branches. -}
-gitAnnexMergeDir :: Git.Repo -> FilePath
-gitAnnexMergeDir r = fromRawFilePath $
- P.addTrailingPathSeparator $ gitAnnexDir r P.</> "merge"
+gitAnnexMergeDir :: Git.Repo -> OsPath
+gitAnnexMergeDir r = addTrailingPathSeparator $
+ gitAnnexDir r </> literalOsPath "merge"
{- .git/annex/transfer/ is used to record keys currently
- being transferred, and other transfer bookkeeping info. -}
-gitAnnexTransferDir :: Git.Repo -> RawFilePath
+gitAnnexTransferDir :: Git.Repo -> OsPath
gitAnnexTransferDir r =
- P.addTrailingPathSeparator $ gitAnnexDir r P.</> "transfer"
+ addTrailingPathSeparator $ gitAnnexDir r </> literalOsPath "transfer"
{- .git/annex/journal/ is used to journal changes made to the git-annex
- branch -}
-gitAnnexJournalDir :: BranchState -> Git.Repo -> RawFilePath
-gitAnnexJournalDir st r = P.addTrailingPathSeparator $
+gitAnnexJournalDir :: BranchState -> Git.Repo -> OsPath
+gitAnnexJournalDir st r = addTrailingPathSeparator $
case alternateJournal st of
- Nothing -> gitAnnexDir r P.</> "journal"
+ Nothing -> gitAnnexDir r </> literalOsPath "journal"
Just d -> d
{- .git/annex/journal.private/ is used to journal changes regarding private
- repositories. -}
-gitAnnexPrivateJournalDir :: BranchState -> Git.Repo -> RawFilePath
-gitAnnexPrivateJournalDir st r = P.addTrailingPathSeparator $
+gitAnnexPrivateJournalDir :: BranchState -> Git.Repo -> OsPath
+gitAnnexPrivateJournalDir st r = addTrailingPathSeparator $
case alternateJournal st of
- Nothing -> gitAnnexDir r P.</> "journal-private"
+ Nothing -> gitAnnexDir r </> literalOsPath "journal-private"
Just d -> d
{- Lock file for the journal. -}
-gitAnnexJournalLock :: Git.Repo -> RawFilePath
-gitAnnexJournalLock r = gitAnnexDir r P.</> "journal.lck"
+gitAnnexJournalLock :: Git.Repo -> OsPath
+gitAnnexJournalLock r = gitAnnexDir r </> literalOsPath "journal.lck"
{- Lock file for flushing a git queue that writes to the git index or
- other git state that should only have one writer at a time. -}
-gitAnnexGitQueueLock :: Git.Repo -> RawFilePath
-gitAnnexGitQueueLock r = gitAnnexDir r P.</> "gitqueue.lck"
+gitAnnexGitQueueLock :: Git.Repo -> OsPath
+gitAnnexGitQueueLock r = gitAnnexDir r </> literalOsPath "gitqueue.lck"
{- .git/annex/index is used to stage changes to the git-annex branch -}
-gitAnnexIndex :: Git.Repo -> RawFilePath
-gitAnnexIndex r = gitAnnexDir r P.</> "index"
+gitAnnexIndex :: Git.Repo -> OsPath
+gitAnnexIndex r = gitAnnexDir r </> literalOsPath "index"
{- .git/annex/index-private is used to store information that is not to
- be exposed to the git-annex branch. -}
-gitAnnexPrivateIndex :: Git.Repo -> RawFilePath
-gitAnnexPrivateIndex r = gitAnnexDir r P.</> "index-private"
+gitAnnexPrivateIndex :: Git.Repo -> OsPath
+gitAnnexPrivateIndex r = gitAnnexDir r </> literalOsPath "index-private"
{- Holds the sha of the git-annex branch that the index was last updated to.
-
- The .lck in the name is a historical accident; this is not used as a
- lock. -}
-gitAnnexIndexStatus :: Git.Repo -> RawFilePath
-gitAnnexIndexStatus r = gitAnnexDir r P.</> "index.lck"
+gitAnnexIndexStatus :: Git.Repo -> OsPath
+gitAnnexIndexStatus r = gitAnnexDir r </> literalOsPath "index.lck"
{- The index file used to generate a filtered branch view._-}
-gitAnnexViewIndex :: Git.Repo -> RawFilePath
-gitAnnexViewIndex r = gitAnnexDir r P.</> "viewindex"
+gitAnnexViewIndex :: Git.Repo -> OsPath
+gitAnnexViewIndex r = gitAnnexDir r </> literalOsPath "viewindex"
{- File containing a log of recently accessed views. -}
-gitAnnexViewLog :: Git.Repo -> RawFilePath
-gitAnnexViewLog r = gitAnnexDir r P.</> "viewlog"
+gitAnnexViewLog :: Git.Repo -> OsPath
+gitAnnexViewLog r = gitAnnexDir r </> literalOsPath "viewlog"
{- List of refs that have already been merged into the git-annex branch. -}
-gitAnnexMergedRefs :: Git.Repo -> RawFilePath
-gitAnnexMergedRefs r = gitAnnexDir r P.</> "mergedrefs"
+gitAnnexMergedRefs :: Git.Repo -> OsPath
+gitAnnexMergedRefs r = gitAnnexDir r </> literalOsPath "mergedrefs"
{- List of refs that should not be merged into the git-annex branch. -}
-gitAnnexIgnoredRefs :: Git.Repo -> RawFilePath
-gitAnnexIgnoredRefs r = gitAnnexDir r P.</> "ignoredrefs"
+gitAnnexIgnoredRefs :: Git.Repo -> OsPath
+gitAnnexIgnoredRefs r = gitAnnexDir r </> literalOsPath "ignoredrefs"
{- Pid file for daemon mode. -}
-gitAnnexPidFile :: Git.Repo -> RawFilePath
-gitAnnexPidFile r = gitAnnexDir r P.</> "daemon.pid"
+gitAnnexPidFile :: Git.Repo -> OsPath
+gitAnnexPidFile r = gitAnnexDir r </> literalOsPath "daemon.pid"
{- Pid lock file for pidlock mode -}
-gitAnnexPidLockFile :: Git.Repo -> RawFilePath
-gitAnnexPidLockFile r = gitAnnexDir r P.</> "pidlock"
+gitAnnexPidLockFile :: Git.Repo -> OsPath
+gitAnnexPidLockFile r = gitAnnexDir r </> literalOsPath "pidlock"
{- Status file for daemon mode. -}
gitAnnexDaemonStatusFile :: Git.Repo -> FilePath
-gitAnnexDaemonStatusFile r = fromRawFilePath $
- gitAnnexDir r P.</> "daemon.status"
+gitAnnexDaemonStatusFile r = fromOsPath $
+ gitAnnexDir r </> literalOsPath "daemon.status"
{- Log file for daemon mode. -}
-gitAnnexDaemonLogFile :: Git.Repo -> RawFilePath
-gitAnnexDaemonLogFile r = gitAnnexDir r P.</> "daemon.log"
+gitAnnexDaemonLogFile :: Git.Repo -> OsPath
+gitAnnexDaemonLogFile r = gitAnnexDir r </> literalOsPath "daemon.log"
{- Log file for fuzz test. -}
gitAnnexFuzzTestLogFile :: Git.Repo -> FilePath
-gitAnnexFuzzTestLogFile r = fromRawFilePath $
- gitAnnexDir r P.</> "fuzztest.log"
+gitAnnexFuzzTestLogFile r = fromOsPath $
+ gitAnnexDir r </> literalOsPath "fuzztest.log"
{- Html shim file used to launch the webapp. -}
-gitAnnexHtmlShim :: Git.Repo -> RawFilePath
-gitAnnexHtmlShim r = gitAnnexDir r P.</> "webapp.html"
+gitAnnexHtmlShim :: Git.Repo -> OsPath
+gitAnnexHtmlShim r = gitAnnexDir r </> literalOsPath "webapp.html"
{- File containing the url to the webapp. -}
-gitAnnexUrlFile :: Git.Repo -> RawFilePath
-gitAnnexUrlFile r = gitAnnexDir r P.</> "url"
+gitAnnexUrlFile :: Git.Repo -> OsPath
+gitAnnexUrlFile r = gitAnnexDir r </> literalOsPath "url"
{- Temporary file used to edit configuriation from the git-annex branch. -}
-gitAnnexTmpCfgFile :: Git.Repo -> RawFilePath
-gitAnnexTmpCfgFile r = gitAnnexDir r P.</> "config.tmp"
+gitAnnexTmpCfgFile :: Git.Repo -> OsPath
+gitAnnexTmpCfgFile r = gitAnnexDir r </> literalOsPath "config.tmp"
{- .git/annex/ssh/ is used for ssh connection caching -}
-gitAnnexSshDir :: Git.Repo -> RawFilePath
-gitAnnexSshDir r = P.addTrailingPathSeparator $ gitAnnexDir r P.</> "ssh"
+gitAnnexSshDir :: Git.Repo -> OsPath
+gitAnnexSshDir r = addTrailingPathSeparator $
+ gitAnnexDir r </> literalOsPath "ssh"
{- .git/annex/remotes/ is used for remote-specific state. -}
-gitAnnexRemotesDir :: Git.Repo -> RawFilePath
-gitAnnexRemotesDir r =
- P.addTrailingPathSeparator $ gitAnnexDir r P.</> "remotes"
+gitAnnexRemotesDir :: Git.Repo -> OsPath
+gitAnnexRemotesDir r = addTrailingPathSeparator $
+ gitAnnexDir r </> literalOsPath "remotes"
{- This is the base directory name used by the assistant when making
- repositories, by default. -}
-gitAnnexAssistantDefaultDir :: FilePath
-gitAnnexAssistantDefaultDir = "annex"
+gitAnnexAssistantDefaultDir :: OsPath
+gitAnnexAssistantDefaultDir = literalOsPath "annex"
-gitAnnexSimDir :: Git.Repo -> RawFilePath
-gitAnnexSimDir r = P.addTrailingPathSeparator $ gitAnnexDir r P.</> "sim"
+gitAnnexSimDir :: Git.Repo -> OsPath
+gitAnnexSimDir r = addTrailingPathSeparator $
+ gitAnnexDir r </> literalOsPath "sim"
{- Sanitizes a String that will be used as part of a Key's keyName,
- dealing with characters that cause problems.
- Changing what this function escapes and how is not a good idea, as it
- can cause existing objects to get lost.
-}
-keyFile :: Key -> RawFilePath
+keyFile :: Key -> OsPath
keyFile k =
- let b = serializeKey' k
- in if S8.any (`elem` ['&', '%', ':', '/']) b
- then S8.concatMap esc b
+ let b = serializeKey'' k
+ in toOsPath $ if SB.any (`elem` needesc) b
+ then SB.concat $ map esc (SB.unpack b)
else b
where
- esc '&' = "&a"
- esc '%' = "&s"
- esc ':' = "&c"
- esc '/' = "%"
- esc c = S8.singleton c
+ esc w = case chr (fromIntegral w) of
+ '&' -> "&a"
+ '%' -> "&s"
+ ':' -> "&c"
+ '/' -> "%"
+ _ -> SB.singleton w
+
+ needesc = map (fromIntegral . ord) ['&', '%', ':', '/']
{- Reverses keyFile, converting a filename fragment (ie, the basename of
- the symlink target) into a key. -}
-fileKey :: RawFilePath -> Maybe Key
-fileKey = deserializeKey' . S8.intercalate "/" . map go . S8.split '%'
+fileKey :: OsPath -> Maybe Key
+fileKey = deserializeKey' . S8.intercalate "/" . map go . S8.split '%' . fromOsPath
where
go = S8.concat . unescafterfirst . S8.split '&'
unescafterfirst [] = []
- The file is put in a directory with the same name, this allows
- write-protecting the directory to avoid accidental deletion of the file.
-}
-keyPath :: Key -> Hasher -> RawFilePath
-keyPath key hasher = hasher key P.</> f P.</> f
+keyPath :: Key -> Hasher -> OsPath
+keyPath key hasher = hasher key </> f </> f
where
f = keyFile key
- This is compatible with the annexLocationsNonBare and annexLocationsBare,
- for interoperability between special remotes and git-annex repos.
-}
-keyPaths :: Key -> NE.NonEmpty RawFilePath
+keyPaths :: Key -> NE.NonEmpty OsPath
keyPaths key = NE.map (\h -> keyPath key (h def)) dirHashes
+
import Annex.LockPool
import qualified Data.Map as M
-import qualified System.FilePath.ByteString as P
{- Create a specified lock file, and takes a shared lock, which is retained
- in the cache. -}
-lockFileCached :: RawFilePath -> Annex ()
+lockFileCached :: OsPath -> Annex ()
lockFileCached file = go =<< fromLockCache file
where
go (Just _) = noop -- already locked
#endif
changeLockCache $ M.insert file lockhandle
-unlockFile :: RawFilePath -> Annex ()
+unlockFile :: OsPath -> Annex ()
unlockFile file = maybe noop go =<< fromLockCache file
where
go lockhandle = do
getLockCache :: Annex LockCache
getLockCache = getState lockcache
-fromLockCache :: RawFilePath -> Annex (Maybe LockHandle)
+fromLockCache :: OsPath -> Annex (Maybe LockHandle)
fromLockCache file = M.lookup file <$> getLockCache
changeLockCache :: (LockCache -> LockCache) -> Annex ()
{- Runs an action with a shared lock held. If an exclusive lock is held,
- blocks until it becomes free. -}
-withSharedLock :: RawFilePath -> Annex a -> Annex a
+withSharedLock :: OsPath -> Annex a -> Annex a
withSharedLock lockfile a = debugLocks $ do
- createAnnexDirectory $ P.takeDirectory lockfile
+ createAnnexDirectory $ takeDirectory lockfile
mode <- annexFileMode
bracket (lock mode lockfile) (liftIO . dropLock) (const a)
where
{- Runs an action with an exclusive lock held. If the lock is already
- held, blocks until it becomes free. -}
-withExclusiveLock :: RawFilePath -> Annex a -> Annex a
+withExclusiveLock :: OsPath -> Annex a -> Annex a
withExclusiveLock lockfile a = bracket
(takeExclusiveLock lockfile)
(liftIO . dropLock)
(const a)
{- Takes an exclusive lock, blocking until it's free. -}
-takeExclusiveLock :: RawFilePath -> Annex LockHandle
+takeExclusiveLock :: OsPath -> Annex LockHandle
takeExclusiveLock lockfile = debugLocks $ do
- createAnnexDirectory $ P.takeDirectory lockfile
+ createAnnexDirectory $ takeDirectory lockfile
mode <- annexFileMode
lock mode lockfile
where
{- Tries to take an exclusive lock and run an action. If the lock is
- already held, returns Nothing. -}
-tryExclusiveLock :: RawFilePath -> Annex a -> Annex (Maybe a)
+tryExclusiveLock :: OsPath -> Annex a -> Annex (Maybe a)
tryExclusiveLock lockfile a = debugLocks $ do
- createAnnexDirectory $ P.takeDirectory lockfile
+ createAnnexDirectory $ takeDirectory lockfile
mode <- annexFileMode
bracket (lock mode lockfile) (liftIO . unlock) go
where
- Does not create the lock directory or lock file if it does not exist,
- taking an exclusive lock will create them.
-}
-trySharedLock :: RawFilePath -> Annex (Maybe LockHandle)
+trySharedLock :: OsPath -> Annex (Maybe LockHandle)
trySharedLock lockfile = debugLocks $
#ifndef mingw32_HOST_OS
tryLockShared Nothing lockfile
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Annex.Magic (
getMagicMimeEncoding,
) where
+import Common
import Types.Mime
import Control.Monad.IO.Class
#ifdef WITH_MAGICMIME
import Utility.Env
import Control.Concurrent
import System.IO.Unsafe (unsafePerformIO)
-import Common
#else
type Magic = ()
#endif
m <- magicOpen [MagicMime]
liftIO $ getEnv "GIT_ANNEX_DIR" >>= \case
Nothing -> magicLoadDefault m
- Just d -> magicLoad m
- (d </> "magic" </> "magic.mgc")
+ Just d -> magicLoad m $ fromOsPath $
+ toOsPath d
+ </> literalOsPath "magic"
+ </> literalOsPath "magic.mgc"
return m
#else
initMagicMime = return Nothing
#endif
-getMagicMime :: Magic -> FilePath -> IO (Maybe (MimeType, MimeEncoding))
+getMagicMime :: Magic -> OsPath -> IO (Maybe (MimeType, MimeEncoding))
#ifdef WITH_MAGICMIME
-getMagicMime m f = Just . parse <$> magicConcurrentSafe (magicFile m f)
+getMagicMime m f = Just . parse <$> magicConcurrentSafe (magicFile m (fromOsPath f))
where
parse s =
let (mimetype, rest) = separate (== ';') s
getMagicMime _ _ = return Nothing
#endif
-getMagicMimeType :: MonadIO m => Magic -> FilePath -> m (Maybe MimeType)
+getMagicMimeType :: MonadIO m => Magic -> OsPath -> m (Maybe MimeType)
getMagicMimeType m f = liftIO $ fmap fst <$> getMagicMime m f
-getMagicMimeEncoding :: MonadIO m => Magic -> FilePath -> m(Maybe MimeEncoding)
+getMagicMimeEncoding :: MonadIO m => Magic -> OsPath -> m(Maybe MimeEncoding)
getMagicMimeEncoding m f = liftIO $ fmap snd <$> getMagicMime m f
#ifdef WITH_MAGICMIME
-
- Also, can generate new metadata, if configured to do so.
-}
-genMetaData :: Key -> RawFilePath -> Maybe POSIXTime -> Annex ()
+genMetaData :: Key -> OsPath -> Maybe POSIXTime -> Annex ()
genMetaData key file mmtime = do
catKeyFileHEAD file >>= \case
Nothing -> noop
Nothing -> noop
where
warncopied = warning $ UnquotedString $
- "Copied metadata from old version of " ++ fromRawFilePath file ++ " to new version. " ++
- "If you don't want this copied metadata, run: git annex metadata --remove-all " ++ fromRawFilePath file
+ "Copied metadata from old version of " ++ fromOsPath file ++ " to new version. " ++
+ "If you don't want this copied metadata, run: git annex metadata --remove-all " ++ fromOsPath file
-- If the only fields copied were date metadata, and they'll
-- be overwritten with the current mtime, no need to warn about
-- copying.
module Annex.Multicast where
+import Common
import Annex.Path
import Utility.Env
-import Utility.PartialPrelude
import System.Process
-import System.IO
import GHC.IO.Handle.FD
-import Control.Applicative
-import Prelude
multicastReceiveEnv :: String
multicastReceiveEnv = "GIT_ANNEX_MULTICAST_RECEIVE"
-multicastCallbackEnv :: IO (FilePath, [(String, String)], Handle)
+multicastCallbackEnv :: IO (OsPath, [(String, String)], Handle)
multicastCallbackEnv = do
gitannex <- programPath
-- This will even work on Windows
{- NumCopies and MinCopies value for a file, from any configuration source,
- including .gitattributes. -}
-getFileNumMinCopies :: RawFilePath -> Annex (NumCopies, MinCopies)
+getFileNumMinCopies :: OsPath -> Annex (NumCopies, MinCopies)
getFileNumMinCopies f = do
fnumc <- getForcedNumCopies
fminc <- getForcedMinCopies
Database.Keys.getAssociatedFilesIncluding afile k
>>= getSafestNumMinCopies' afile k
-getSafestNumMinCopies' :: AssociatedFile -> Key -> [RawFilePath] -> Annex (NumCopies, MinCopies)
+getSafestNumMinCopies' :: AssociatedFile -> Key -> [OsPath] -> Annex (NumCopies, MinCopies)
getSafestNumMinCopies' afile k fs = do
l <- mapM getFileNumMinCopies fs
let l' = zip l fs
{- This is the globally visible numcopies value for a file. So it does
- not include local configuration in the git config or command line
- options. -}
-getGlobalFileNumCopies :: RawFilePath -> Annex NumCopies
+getGlobalFileNumCopies :: OsPath -> Annex NumCopies
getGlobalFileNumCopies f = fromSourcesOr defaultNumCopies
[ fst <$> getNumMinCopiesAttr f
, getGlobalNumCopies
]
-getNumMinCopiesAttr :: RawFilePath -> Annex (Maybe NumCopies, Maybe MinCopies)
+getNumMinCopiesAttr :: OsPath -> Annex (Maybe NumCopies, Maybe MinCopies)
getNumMinCopiesAttr file =
checkAttrs ["annex.numcopies", "annex.mincopies"] file >>= \case
(n:m:[]) -> return
- This is good enough for everything except dropping the file, which
- requires active verification of the copies.
-}
-numCopiesCheck :: RawFilePath -> Key -> (Int -> Int -> v) -> Annex v
+numCopiesCheck :: OsPath -> Key -> (Int -> Int -> v) -> Annex v
numCopiesCheck file key vs = do
have <- trustExclude UnTrusted =<< Remote.keyLocations key
numCopiesCheck' file vs have
-numCopiesCheck' :: RawFilePath -> (Int -> Int -> v) -> [UUID] -> Annex v
+numCopiesCheck' :: OsPath -> (Int -> Int -> v) -> [UUID] -> Annex v
numCopiesCheck' file vs have = do
needed <- fst <$> getFileNumMinCopies file
let nhave = numCopiesCount have
- git-annex-shell or git-remote-annex, this finds a git-annex program
- instead.
-}
-programPath :: IO FilePath
+programPath :: IO OsPath
programPath = go =<< getEnv "GIT_ANNEX_DIR"
where
go (Just dir) = do
name <- reqgitannex <$> getProgName
- return (dir </> name)
+ return (toOsPath dir </> toOsPath name)
go Nothing = do
name <- getProgName
exe <- if isgitannex name
then getExecutablePath
else pure "git-annex"
- p <- if isAbsolute exe
+ p <- if isAbsolute (toOsPath exe)
then return exe
- else fromMaybe exe <$> readProgramFile
+ else maybe exe fromOsPath <$> readProgramFile
maybe cannotFindProgram return =<< searchPath p
reqgitannex name
isgitannex = flip M.notMember otherMulticallCommands
{- Returns the path for git-annex that is recorded in the programFile. -}
-readProgramFile :: IO (Maybe FilePath)
+readProgramFile :: IO (Maybe OsPath)
readProgramFile = catchDefaultIO Nothing $ do
programfile <- programFile
- headMaybe . lines <$> readFile programfile
+ fmap toOsPath . headMaybe . lines <$> readFile (fromOsPath programfile)
cannotFindProgram :: IO a
cannotFindProgram = do
f <- programFile
- giveup $ "cannot find git-annex program in PATH or in " ++ f
+ giveup $ "cannot find git-annex program in PATH or in " ++ fromOsPath f
{- Runs a git-annex child process.
-
gitAnnexChildProcess subcmd ps f a = do
cmd <- liftIO programPath
ps' <- gitAnnexChildProcessParams subcmd ps
- pidLockChildProcess cmd ps' f a
+ pidLockChildProcess (fromOsPath cmd) ps' f a
{- Parameters to pass to a git-annex child process to run a subcommand
- with some parameters.
withShared :: (SharedRepository -> Annex a) -> Annex a
withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig
-setAnnexFilePerm :: RawFilePath -> Annex ()
+setAnnexFilePerm :: OsPath -> Annex ()
setAnnexFilePerm = setAnnexPerm False
-setAnnexDirPerm :: RawFilePath -> Annex ()
+setAnnexDirPerm :: OsPath -> Annex ()
setAnnexDirPerm = setAnnexPerm True
{- Sets appropriate file mode for a file or directory in the annex,
- other than the content files and content directory. Normally,
- don't change the mode, but with core.sharedRepository set,
- allow the group to write, etc. -}
-setAnnexPerm :: Bool -> RawFilePath -> Annex ()
+setAnnexPerm :: Bool -> OsPath -> Annex ()
setAnnexPerm isdir file = setAnnexPerm' Nothing isdir >>= \go -> liftIO (go file)
-setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> Annex (RawFilePath -> IO ())
+setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> Annex (OsPath -> IO ())
setAnnexPerm' modef isdir = ifM crippledFileSystem
( return (const noop)
, withShared $ \s -> return $ \file -> go s file
Nothing -> noop
Just f -> void $ tryIO $
modifyFileMode file $ f []
- go (UmaskShared n) file = void $ tryIO $ R.setFileMode file $
- if isdir then umaskSharedDirectory n else n
+ go (UmaskShared n) file = void $ tryIO $
+ R.setFileMode (fromOsPath file) $
+ if isdir then umaskSharedDirectory n else n
modef' = fromMaybe addModes modef
-resetAnnexFilePerm :: RawFilePath -> Annex ()
+resetAnnexFilePerm :: OsPath -> Annex ()
resetAnnexFilePerm = resetAnnexPerm False
{- Like setAnnexPerm, but ignores the current mode of the file entirely,
- which is going to be moved to a non-temporary location and needs
- usual modes.
-}
-resetAnnexPerm :: Bool -> RawFilePath -> Annex ()
+resetAnnexPerm :: Bool -> OsPath -> Annex ()
resetAnnexPerm isdir file = unlessM crippledFileSystem $ do
defmode <- liftIO defaultFileMode
let modef moremodes _oldmode = addModes moremodes defmode
{- Creates a directory inside the gitAnnexDir (or possibly the dbdir),
- creating any parent directories up to and including the gitAnnexDir.
- Makes directories with appropriate permissions. -}
-createAnnexDirectory :: RawFilePath -> Annex ()
+createAnnexDirectory :: OsPath -> Annex ()
createAnnexDirectory dir = do
top <- parentDir <$> fromRepo gitAnnexDir
tops <- annexDbDir <$> Annex.getGitConfig >>= return . \case
createDirectoryUnder' tops dir createdir
where
createdir p = do
- liftIO $ R.createDirectory p
+ liftIO $ createDirectory p
setAnnexDirPerm p
{- Create a directory in the git work tree, creating any parent
-
- Uses default permissions.
-}
-createWorkTreeDirectory :: RawFilePath -> Annex ()
+createWorkTreeDirectory :: OsPath -> Annex ()
createWorkTreeDirectory dir = do
fromRepo repoWorkTree >>= liftIO . \case
Just wt -> createDirectoryUnder [wt] dir
- it should not normally have. checkContentWritePerm can detect when
- that happens with write permissions.
-}
-freezeContent :: RawFilePath -> Annex ()
+freezeContent :: OsPath -> Annex ()
freezeContent file =
withShared $ \sr -> freezeContent' sr file
-freezeContent' :: SharedRepository -> RawFilePath -> Annex ()
+freezeContent' :: SharedRepository -> OsPath -> Annex ()
freezeContent' sr file = freezeContent'' sr file =<< getVersion
-freezeContent'' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Annex ()
+freezeContent'' :: SharedRepository -> OsPath -> Maybe RepoVersion -> Annex ()
freezeContent'' sr file rv = do
- fastDebug "Annex.Perms" ("freezing content " ++ fromRawFilePath file)
+ fastDebug "Annex.Perms" ("freezing content " ++ fromOsPath file)
unlessM crippledFileSystem $ go sr
freezeHook file
where
- support removing write permissions, so when there is such a hook
- write permissions are ignored.
-}
-checkContentWritePerm :: RawFilePath -> Annex (Maybe Bool)
+checkContentWritePerm :: OsPath -> Annex (Maybe Bool)
checkContentWritePerm file = ifM crippledFileSystem
( return (Just True)
, do
liftIO $ checkContentWritePerm' sr file rv hasfreezehook
)
-checkContentWritePerm' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Bool -> IO (Maybe Bool)
+checkContentWritePerm' :: SharedRepository -> OsPath -> Maybe RepoVersion -> Bool -> IO (Maybe Bool)
checkContentWritePerm' sr file rv hasfreezehook
| hasfreezehook = return (Just True)
| otherwise = case sr of
| otherwise -> want sharedret
(\havemode -> havemode == removeModes writeModes n)
where
- want mk f = catchMaybeIO (fileMode <$> R.getFileStatus file)
+ want mk f = catchMaybeIO (fileMode <$> R.getFileStatus (fromOsPath file))
>>= return . \case
Just havemode -> mk (f havemode)
Nothing -> mk True
{- Allows writing to an annexed file that freezeContent was called on
- before. -}
-thawContent :: RawFilePath -> Annex ()
+thawContent :: OsPath -> Annex ()
thawContent file = withShared $ \sr -> thawContent' sr file
-thawContent' :: SharedRepository -> RawFilePath -> Annex ()
+thawContent' :: SharedRepository -> OsPath -> Annex ()
thawContent' sr file = do
- fastDebug "Annex.Perms" ("thawing content " ++ fromRawFilePath file)
+ fastDebug "Annex.Perms" ("thawing content " ++ fromOsPath file)
thawPerms (go sr) (thawHook file)
where
go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file
go AllShared = liftIO $ void $ tryIO $ groupWriteRead file
go UnShared = liftIO $ allowWrite file
- go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode file n
+ go (UmaskShared n) = liftIO $ void $ tryIO $
+ R.setFileMode (fromOsPath file) n
{- Runs an action that thaws a file's permissions. This will probably
- fail on a crippled filesystem. But, if file modes are supported on a
- is set, this is not done, since the group must be allowed to delete the
- file without being able to thaw the directory.
-}
-freezeContentDir :: RawFilePath -> Annex ()
+freezeContentDir :: OsPath -> Annex ()
freezeContentDir file = do
- fastDebug "Annex.Perms" ("freezing content directory " ++ fromRawFilePath dir)
+ fastDebug "Annex.Perms" ("freezing content directory " ++ fromOsPath dir)
unlessM crippledFileSystem $ withShared go
freezeHook dir
where
go UnShared = liftIO $ preventWrite dir
go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir
go AllShared = liftIO $ void $ tryIO $ groupWriteRead dir
- go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode dir $
+ go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode (fromOsPath dir) $
umaskSharedDirectory $
- -- If n includes group or other write mode, leave them set
- -- to allow them to delete the file without being able to
- -- thaw the directory.
+ -- If n includes group or other write mode, leave
+ -- them set to allow them to delete the file without
+ -- being able to thaw the directory.
removeModes [ownerWriteMode] n
-thawContentDir :: RawFilePath -> Annex ()
+thawContentDir :: OsPath -> Annex ()
thawContentDir file = do
- fastDebug "Annex.Perms" ("thawing content directory " ++ fromRawFilePath dir)
+ fastDebug "Annex.Perms" ("thawing content directory " ++ fromOsPath dir)
thawPerms (withShared (liftIO . go)) (thawHook dir)
where
dir = parentDir file
go UnShared = allowWrite dir
go GroupShared = allowWrite dir
go AllShared = allowWrite dir
- go (UmaskShared n) = R.setFileMode dir n
+ go (UmaskShared n) = R.setFileMode (fromOsPath dir) n
{- Makes the directory tree to store an annexed file's content,
- with appropriate permissions on each level. -}
-createContentDir :: RawFilePath -> Annex ()
+createContentDir :: OsPath -> Annex ()
createContentDir dest = do
- unlessM (liftIO $ R.doesPathExist dir) $
+ unlessM (liftIO $ doesDirectoryExist dir) $
createAnnexDirectory dir
-- might have already existed with restricted perms
thawHook dir
{- Creates the content directory for a file if it doesn't already exist,
- or thaws it if it does, then runs an action to modify a file in the
- directory, and finally, freezes the content directory. -}
-modifyContentDir :: RawFilePath -> Annex a -> Annex a
+modifyContentDir :: OsPath -> Annex a -> Annex a
modifyContentDir f a = do
createContentDir f -- also thaws it
v <- tryNonAsync a
{- Like modifyContentDir, but avoids creating the content directory if it
- does not already exist. In that case, the action will probably fail. -}
-modifyContentDirWhenExists :: RawFilePath -> Annex a -> Annex a
+modifyContentDirWhenExists :: OsPath -> Annex a -> Annex a
modifyContentDirWhenExists f a = do
thawContentDir f
v <- tryNonAsync a
<||>
(doesAnnexHookExist thawContentAnnexHook)
-freezeHook :: RawFilePath -> Annex ()
+freezeHook :: OsPath -> Annex ()
freezeHook = void . runAnnexPathHook "%path"
freezeContentAnnexHook annexFreezeContentCommand
-thawHook :: RawFilePath -> Annex ()
+thawHook :: OsPath -> Annex ()
thawHook = void . runAnnexPathHook "%path"
thawContentAnnexHook annexThawContentCommand
import Control.Concurrent.STM
import Control.Concurrent.Async
import qualified Data.ByteString as B
-import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
-import qualified System.FilePath.ByteString as P
import qualified Data.Map as M
import qualified Data.Set as S
+#ifndef mingw32_HOST_OS
+import qualified Data.ByteString as BS
import System.IO.Unsafe
+#endif
proxyRemoteSide :: ProtocolVersion -> Bypass -> Remote -> Annex RemoteSide
proxyRemoteSide clientmaxversion bypass r
-- independently. Also, this key is not getting added into the
-- local annex objects.
withproxytmpfile k a = withOtherTmp $ \othertmpdir ->
- withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "proxy") $ \tmpdir ->
- a (toRawFilePath tmpdir P.</> keyFile k)
+ withTmpDirIn othertmpdir (literalOsPath "proxy") $ \tmpdir ->
+ a (tmpdir </> keyFile k)
proxyput af k = do
liftIO $ sendmessage $ PUT_FROM (Offset 0)
-- the client, to avoid bad content
-- being stored in the special remote.
iv <- startVerifyKeyContentIncrementally Remote.AlwaysVerify k
- h <- liftIO $ F.openFile (toOsPath tmpfile) WriteMode
- let nuketmp = liftIO $ removeWhenExistsWith removeFile (fromRawFilePath tmpfile)
+ h <- liftIO $ F.openFile tmpfile WriteMode
+ let nuketmp = liftIO $ removeWhenExistsWith removeFile tmpfile
gotall <- liftIO $ receivetofile iv h len
liftIO $ hClose h
verified <- if gotall
then fst <$> finishVerifyKeyContentIncrementally' True iv
else pure False
- let store = tryNonAsync (storeput k af (decodeBS tmpfile)) >>= \case
+ let store = tryNonAsync (storeput k af tmpfile) >>= \case
Right () -> liftIO $ sendmessage SUCCESS
Left err -> liftIO $ propagateerror err
if protoversion > ProtocolVersion 1
storetofile iv h (n - fromIntegral (B.length b)) bs
proxyget offset af k = withproxytmpfile k $ \tmpfile -> do
- let retrieve = tryNonAsync $ Remote.retrieveKeyFile r k af
- (fromRawFilePath tmpfile) nullMeterUpdate vc
+ let retrieve = tryNonAsync $ Remote.retrieveKeyFile
+ r k af tmpfile nullMeterUpdate vc
+#ifndef mingw32_HOST_OS
ordered <- Remote.retrieveKeyFileInOrder r
+#else
+ _ <- Remote.retrieveKeyFileInOrder r
+#endif
case fromKey keySize k of
#ifndef mingw32_HOST_OS
Just size | size > 0 && ordered -> do
sendlen offset size
waitforfile
x <- tryNonAsync $ do
- h <- openFileBeingWritten f
+ h <- openFileBeingWritten (fromOsPath f)
hSeek h AbsoluteSeek offset
senddata' h (getcontents size)
case x of
senddata (Offset offset) f = do
size <- fromIntegral <$> getFileSize f
sendlen offset size
- withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do
+ F.withBinaryFile f ReadMode $ \h -> do
hSeek h AbsoluteSeek offset
senddata' h L.hGetContents
store =<< flushWhenFull =<<
(Git.Queue.addCommand commonparams command params files q =<< gitRepo)
-addFlushAction :: Git.Queue.FlushActionRunner Annex -> [RawFilePath] -> Annex ()
+addFlushAction :: Git.Queue.FlushActionRunner Annex -> [OsPath] -> Annex ()
addFlushAction runner files = do
q <- get
store =<< flushWhenFull =<<
import Utility.Tmp.Dir
import Utility.Directory.Create
-import qualified System.FilePath.ByteString as P
-
{- replaceFile on a file located inside the gitAnnexDir. -}
-replaceGitAnnexDirFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
+replaceGitAnnexDirFile :: OsPath -> (OsPath -> Annex a) -> Annex a
replaceGitAnnexDirFile = replaceFile createAnnexDirectory
{- replaceFile on a file located inside the .git directory. -}
-replaceGitDirFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
+replaceGitDirFile :: OsPath -> (OsPath -> Annex a) -> Annex a
replaceGitDirFile = replaceFile $ \dir -> do
top <- fromRepo localGitDir
liftIO $ createDirectoryUnder [top] dir
{- replaceFile on a worktree file. -}
-replaceWorkTreeFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
+replaceWorkTreeFile :: OsPath -> (OsPath -> Annex a) -> Annex a
replaceWorkTreeFile = replaceFile createWorkTreeDirectory
{- Replaces a possibly already existing file with a new version,
- The createdirectory action is only run when moving the file into place
- fails, and can create any parent directory structure needed.
-}
-replaceFile :: (RawFilePath -> Annex ()) -> RawFilePath -> (RawFilePath -> Annex a) -> Annex a
+replaceFile :: (OsPath -> Annex ()) -> OsPath -> (OsPath -> Annex a) -> Annex a
replaceFile createdirectory file action = replaceFile' createdirectory file (const True) action
-replaceFile' :: (RawFilePath -> Annex ()) -> RawFilePath -> (a -> Bool) -> (RawFilePath -> Annex a) -> Annex a
+replaceFile' :: (OsPath -> Annex ()) -> OsPath -> (a -> Bool) -> (OsPath -> Annex a) -> Annex a
replaceFile' createdirectory file checkres action = withOtherTmp $ \othertmpdir -> do
- let basetmp = relatedTemplate' (P.takeFileName file)
- withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath basetmp) $ \tmpdir -> do
- let tmpfile = toRawFilePath tmpdir P.</> basetmp
+ let basetmp = relatedTemplate (fromOsPath (takeFileName file))
+ withTmpDirIn othertmpdir basetmp $ \tmpdir -> do
+ let tmpfile = tmpdir </> basetmp
r <- action tmpfile
when (checkres r) $
replaceFileFrom tmpfile file createdirectory
return r
-replaceFileFrom :: RawFilePath -> RawFilePath -> (RawFilePath -> Annex ()) -> Annex ()
+replaceFileFrom :: OsPath -> OsPath -> (OsPath -> Annex ()) -> Annex ()
replaceFileFrom src dest createdirectory = go `catchIO` fallback
where
go = liftIO $ moveFile src dest
import Control.Concurrent
import Text.Read
import Data.Time.Clock.POSIX
-import qualified Utility.RawFilePath as R
-import qualified System.FilePath.ByteString as P
{- Called when a location log change is journalled, so the LiveUpdate
- is done. This is called with the journal still locked, so no concurrent
checkStaleSizeChanges h@(RepoSizeHandle (Just _) livev) = do
livedir <- calcRepo' gitAnnexRepoSizeLiveDir
pid <- liftIO getPID
- let pidlockfile = show pid
+ let pidlockfile = toOsPath (show pid)
now <- liftIO getPOSIXTime
liftIO (takeMVar livev) >>= \case
Nothing -> do
- lck <- takeExclusiveLock $
- livedir P.</> toRawFilePath pidlockfile
+ lck <- takeExclusiveLock $ livedir </> pidlockfile
go livedir lck pidlockfile now
Just v@(lck, lastcheck)
| now >= lastcheck + 60 ->
where
go livedir lck pidlockfile now = do
void $ tryNonAsync $ do
- lockfiles <- liftIO $ filter (not . dirCruft . toRawFilePath)
- <$> getDirectoryContents (fromRawFilePath livedir)
+ lockfiles <- liftIO $ filter (`notElem` dirCruft)
+ <$> getDirectoryContents livedir
stale <- forM lockfiles $ \lockfile ->
if (lockfile /= pidlockfile)
- then case readMaybe lockfile of
+ then case readMaybe (fromOsPath lockfile) of
Nothing -> return Nothing
Just pid -> checkstale livedir lockfile pid
else return Nothing
liftIO $ putMVar livev (Just (lck, now))
checkstale livedir lockfile pid =
- let f = livedir P.</> toRawFilePath lockfile
+ let f = livedir </> lockfile
in trySharedLock f >>= \case
Nothing -> return Nothing
Just lck -> do
( StaleSizeChanger (SizeChangeProcessId pid)
, do
dropLock lck
- removeWhenExistsWith R.removeLink f
+ removeWhenExistsWith removeFile f
)
checkStaleSizeChanges (RepoSizeHandle Nothing _) = noop
import qualified Data.ByteString.Lazy as L
import qualified Data.UUID as U
import qualified Data.UUID.V5 as U5
-import qualified Utility.RawFilePath as R
-import qualified System.FilePath.ByteString as P
data SimState t = SimState
{ simRepos :: M.Map RepoName UUID
_ -> return ("sh", ["-c", unwords cmdparams])
exitcode <- liftIO $
safeSystem' cmd (map Param params)
- (\p -> p { cwd = Just dir })
+ (\p -> p { cwd = Just (fromOsPath dir) })
when (null cmdparams) $
showLongNote "Finished visit to simulated repository."
if null cmdparams
<$> inRepo (toTopFilePath f)
ifM (checkMatcher matcher (Just k) afile NoLiveUpdate mempty (pure False) (pure False))
( let st'' = setPresentKey True (u, repo) k u $ st'
- { simFiles = M.insert f k (simFiles st')
+ { simFiles = M.insert (fromOsPath f) k (simFiles st')
}
in go matcher u st'' fs
, go matcher u st' fs
Right (Left (st, map (go remoteu) $ M.toList $ simFiles st))
where
go remoteu (f, k) st' =
- let af = AssociatedFile $ Just f
+ let af = AssociatedFile $ Just $ toOsPath f
in liftIO $ runSimRepo u st' $ \st'' rst ->
case M.lookup remoteu (simRepoState st'') of
Nothing -> return (st'', False)
Right $ Left (st, map go $ M.toList $ simFiles st)
where
go (f, k) st' = liftIO $ runSimRepo u st' $ \st'' rst ->
- let af = AssociatedFile $ Just f
+ let af = AssociatedFile $ Just $ toOsPath f
in if present dropfrom rst k
then updateLiveSizeChanges rst $
ifM (wantDrop NoLiveUpdate False (Just dropfrom) (Just k) af Nothing)
go st ((u, rst):rest) =
case simRepo rst of
Nothing -> do
- let d = simRepoDirectory st u
+ let d = fromOsPath $ simRepoDirectory st u
sr <- initSimRepo (simRepoName rst) u d st
let rst' = rst { simRepo = Just sr }
let st' = st
go st' rest
_ -> go st rest
-simRepoDirectory :: SimState t -> UUID -> FilePath
-simRepoDirectory st u = simRootDirectory st </> fromUUID u
+simRepoDirectory :: SimState t -> UUID -> OsPath
+simRepoDirectory st u = toOsPath (simRootDirectory st) </> fromUUID u
initSimRepo :: RepoName -> UUID -> FilePath -> SimState SimRepo -> IO SimRepo
initSimRepo simreponame u dest st = do
]
unless inited $
giveup "git init failed"
- simrepo <- Git.Construct.fromPath (toRawFilePath dest)
+ simrepo <- Git.Construct.fromPath (toOsPath dest)
ast <- Annex.new simrepo
((), ast') <- Annex.run ast $ doQuietAction $ do
storeUUID u
setdesc r u = describeUUID u $ toUUIDDesc $
simulatedRepositoryDescription r
stageannexedfile f k = do
- let f' = annexedfilepath f
+ let f' = annexedfilepath (toOsPath f)
l <- calcRepo $ gitAnnexLink f' k
- liftIO $ createDirectoryIfMissing True $
- takeDirectory $ fromRawFilePath f'
- addAnnexLink l f'
- unstageannexedfile f = do
- liftIO $ removeWhenExistsWith R.removeLink $
- annexedfilepath f
- annexedfilepath f = repoPath (simRepoGitRepo sr) P.</> f
+ liftIO $ createDirectoryIfMissing True $ takeDirectory f'
+ addAnnexLink (fromOsPath l) f'
+ unstageannexedfile f =
+ liftIO $ removeWhenExistsWith removeFile $
+ annexedfilepath (toOsPath f)
+ annexedfilepath f = repoPath (simRepoGitRepo sr) </> f
getlocations = maybe mempty simLocations
. M.lookup (simRepoUUID sr)
. simRepoState
let st'' = st'
{ simRepoState = M.map freeze (simRepoState st')
}
- writeFile (simRootDirectory st'' </> "state") (show st'')
+ let statefile = fromOsPath $
+ toOsPath (simRootDirectory st'') </> literalOsPath "state"
+ writeFile statefile (show st'')
where
freeze :: SimRepoState SimRepo -> SimRepoState ()
freeze rst = rst { simRepo = Nothing }
-restoreSim :: RawFilePath -> IO (Either String (SimState SimRepo))
+restoreSim :: OsPath -> IO (Either String (SimState SimRepo))
restoreSim rootdir =
- tryIO (readFile (fromRawFilePath rootdir </> "state")) >>= \case
+ tryIO (readFile statefile) >>= \case
Left err -> return (Left (show err))
Right c -> case readMaybe c :: Maybe (SimState ()) of
Nothing -> return (Left "unable to parse sim state file")
Just st -> do
- let st' = st { simRootDirectory = fromRawFilePath rootdir }
+ let st' = st { simRootDirectory = fromOsPath rootdir }
repostate <- M.fromList
<$> mapM (thaw st') (M.toList (simRepoState st))
let st'' = st'
}
return (Right st'')
where
+ statefile = fromOsPath $ rootdir </> literalOsPath "state"
thaw st (u, rst) = tryNonAsync (thaw' st u) >>= return . \case
Left _ -> (u, rst { simRepo = Nothing })
Right r -> (u, rst { simRepo = Just r })
thaw' st u = do
- simrepo <- Git.Construct.fromPath $ toRawFilePath $
- simRepoDirectory st u
+ simrepo <- Git.Construct.fromPath $ simRepoDirectory st u
ast <- Annex.new simrepo
return $ SimRepo
{ simRepoGitRepo = simrepo
import Git.Env
import Git.Ssh
import qualified Utility.RawFilePath as R
+import qualified Utility.OsString as OS
import Annex.Perms
#ifndef mingw32_HOST_OS
import Annex.LockPool
#endif
import Control.Concurrent.STM
-import qualified Data.ByteString as S
-import qualified System.FilePath.ByteString as P
+import qualified Data.ByteString.Short as SBS
{- Some ssh commands are fed stdin on a pipe and so should be allowed to
- consume it. But ssh commands that are not piped stdin should generally
{- Returns a filename to use for a ssh connection caching socket, and
- parameters to enable ssh connection caching. -}
-sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe RawFilePath, [CommandParam])
+sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe OsPath, [CommandParam])
sshCachingInfo (host, port) = go =<< sshCacheDir'
where
go (Right dir) =
- liftIO (bestSocketPath $ dir P.</> hostport2socket host port) >>= return . \case
+ liftIO (bestSocketPath $ dir </> hostport2socket host port) >>= return . \case
Nothing -> (Nothing, [])
Just socketfile ->
(Just socketfile
- , sshConnectionCachingParams (fromRawFilePath socketfile)
+ , sshConnectionCachingParams (fromOsPath socketfile)
)
-- No connection caching with concurrency is not a good
-- combination, so warn the user.
- file.
-
- If no path can be constructed that is a valid socket, returns Nothing. -}
-bestSocketPath :: RawFilePath -> IO (Maybe RawFilePath)
+bestSocketPath :: OsPath -> IO (Maybe OsPath)
bestSocketPath abssocketfile = do
relsocketfile <- liftIO $ relPathCwdToFile abssocketfile
- let socketfile = if S.length abssocketfile <= S.length relsocketfile
+ let socketfile = if OS.length abssocketfile <= OS.length relsocketfile
then abssocketfile
else relsocketfile
return $ if valid_unix_socket_path socketfile sshgarbagelen
-
- The directory will be created if it does not exist.
-}
-sshCacheDir :: Annex (Maybe RawFilePath)
+sshCacheDir :: Annex (Maybe OsPath)
sshCacheDir = eitherToMaybe <$> sshCacheDir'
-sshCacheDir' :: Annex (Either String RawFilePath)
+sshCacheDir' :: Annex (Either String OsPath)
sshCacheDir' =
ifM (fromMaybe BuildInfo.sshconnectioncaching . annexSshCaching <$> Annex.getGitConfig)
( ifM crippledFileSystem
gettmpdir = liftIO $ getEnv sshSocketDirEnv
usetmpdir tmpdir = do
- let socktmp = tmpdir </> "ssh"
+ let socktmp = toOsPath tmpdir </> literalOsPath "ssh"
createDirectoryIfMissing True socktmp
- return (toRawFilePath socktmp)
+ return socktmp
crippledfswarning = unwords
[ "This repository is on a crippled filesystem, so unix named"
- Locks the socket lock file to prevent other git-annex processes from
- stopping the ssh multiplexer on this socket.
-}
-prepSocket :: RawFilePath -> SshHost -> [CommandParam] -> Annex ()
+prepSocket :: OsPath -> SshHost -> [CommandParam] -> Annex ()
prepSocket socketfile sshhost sshparams = do
-- There could be stale ssh connections hanging around
-- from a previous git-annex run that was interrupted.
- and this check makes such files be skipped since the corresponding lock
- file won't exist.
-}
-enumSocketFiles :: Annex [RawFilePath]
+enumSocketFiles :: Annex [OsPath]
enumSocketFiles = liftIO . go =<< sshCacheDir
where
go Nothing = return []
- go (Just dir) = filterM (R.doesPathExist . socket2lock)
+ go (Just dir) = filterM (R.doesPathExist . fromOsPath . socket2lock)
=<< filter (not . isLock)
<$> catchDefaultIO [] (dirContents dir)
forceSshCleanup :: Annex ()
forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles
-forceStopSsh :: RawFilePath -> Annex ()
+forceStopSsh :: OsPath -> Annex ()
forceStopSsh socketfile = withNullHandle $ \nullh -> do
- let (dir, base) = splitFileName (fromRawFilePath socketfile)
+ let (dir, base) = splitFileName socketfile
let p = (proc "ssh" $ toCommand $
[ Param "-O", Param "stop" ] ++
- sshConnectionCachingParams base ++
+ sshConnectionCachingParams (fromOsPath base) ++
[Param "localhost"])
- { cwd = Just dir
+ { cwd = Just (fromOsPath dir)
-- "ssh -O stop" is noisy on stderr even with -q
, std_out = UseHandle nullh
, std_err = UseHandle nullh
}
void $ liftIO $ catchMaybeIO $ withCreateProcess p $ \_ _ _ pid ->
forceSuccessProcess p pid
- liftIO $ removeWhenExistsWith R.removeLink socketfile
+ liftIO $ removeWhenExistsWith removeFile socketfile
{- This needs to be as short as possible, due to limitations on the length
- of the path to a socket file. At the same time, it needs to be unique
- for each host.
-}
-hostport2socket :: SshHost -> Maybe Integer -> RawFilePath
+hostport2socket :: SshHost -> Maybe Integer -> OsPath
hostport2socket host Nothing = hostport2socket' $ fromSshHost host
hostport2socket host (Just port) = hostport2socket' $
fromSshHost host ++ "!" ++ show port
-hostport2socket' :: String -> RawFilePath
+hostport2socket' :: String -> OsPath
hostport2socket' s
- | length s > lengthofmd5s = toRawFilePath $ show $ md5 $ encodeBL s
- | otherwise = toRawFilePath s
+ | length s > lengthofmd5s = toOsPath $ show $ md5 $ encodeBL s
+ | otherwise = toOsPath s
where
lengthofmd5s = 32
-socket2lock :: RawFilePath -> RawFilePath
+socket2lock :: OsPath -> OsPath
socket2lock socket = socket <> lockExt
-isLock :: RawFilePath -> Bool
-isLock f = lockExt `S.isSuffixOf` f
+isLock :: OsPath -> Bool
+isLock f = lockExt `OS.isSuffixOf` f
-lockExt :: S.ByteString
-lockExt = ".lock"
+lockExt :: OsPath
+lockExt = literalOsPath ".lock"
{- This is the size of the sun_path component of sockaddr_un, which
- is the limit to the total length of the filename of a unix socket.
{- Note that this looks at the true length of the path in bytes, as it will
- appear on disk. -}
-valid_unix_socket_path :: RawFilePath -> Int -> Bool
-valid_unix_socket_path f n = S.length f + n < sizeof_sockaddr_un_sun_path
+valid_unix_socket_path :: OsPath -> Int -> Bool
+valid_unix_socket_path f n =
+ SBS.length (fromOsPath f) + n < sizeof_sockaddr_un_sun_path
{- Parses the SSH port, and returns the other OpenSSH options. If
- several ports are found, the last one takes precedence. -}
liftIO $ do
localr' <- addGitEnv localr sshOptionsEnv
(toSshOptionsEnv sshopts)
- addGitEnv localr' gitSshEnv command
+ addGitEnv localr' gitSshEnv (fromOsPath command)
runSshOptions :: [String] -> String -> IO ()
runSshOptions args s = do
-- directory that is passed to it. However, once the action is done,
-- any files left in that directory may be cleaned up by another process at
-- any time.
-withOtherTmp :: (RawFilePath -> Annex a) -> Annex a
+withOtherTmp :: (OsPath -> Annex a) -> Annex a
withOtherTmp a = do
Annex.addCleanupAction OtherTmpCleanup cleanupOtherTmp
tmpdir <- fromRepo gitAnnexTmpOtherDir
-- Unlike withOtherTmp, this does not rely on locking working.
-- Its main use is in situations where the state of lockfile is not
-- determined yet, eg during initialization.
-withEventuallyCleanedOtherTmp :: (RawFilePath -> Annex a) -> Annex a
+withEventuallyCleanedOtherTmp :: (OsPath -> Annex a) -> Annex a
withEventuallyCleanedOtherTmp = bracket setup cleanup
where
setup = do
tmpdir <- fromRepo gitAnnexTmpOtherDirOld
void $ createAnnexDirectory tmpdir
return tmpdir
- cleanup = liftIO . void . tryIO . removeDirectory . fromRawFilePath
+ cleanup = liftIO . void . tryIO . removeDirectory
-- | Cleans up any tmp files that were left by a previous
-- git-annex process that got interrupted or failed to clean up after
cleanupOtherTmp = do
tmplck <- fromRepo gitAnnexTmpOtherLock
void $ tryIO $ tryExclusiveLock tmplck $ do
- tmpdir <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDir
+ tmpdir <- fromRepo gitAnnexTmpOtherDir
void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir
oldtmp <- fromRepo gitAnnexTmpOtherDirOld
- liftIO $ mapM_ cleanold
+ liftIO $ mapM_ (cleanold . fromOsPath)
=<< emptyWhenDoesNotExist (dirContentsRecursive oldtmp)
-- remove when empty
- liftIO $ void $ tryIO $
- removeDirectory (fromRawFilePath oldtmp)
+ liftIO $ void $ tryIO $ removeDirectory oldtmp
where
cleanold f = do
now <- liftIO getPOSIXTime
import Annex.StallDetection
import Backend (isCryptographicallySecureKey)
import Types.StallDetection
-import qualified Utility.RawFilePath as R
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM hiding (retry)
import qualified Data.Map.Strict as M
-import qualified System.FilePath.ByteString as P
import Data.Ord
-- Upload, supporting canceling detected stalls.
go sd = getViaTmp (Remote.retrievalSecurityPolicy r) vc key f Nothing $ \dest ->
download' (Remote.uuid r) key f sd d (go' dest) witness
go' dest p = verifiedAction $
- Remote.retrieveKeyFile r key f (fromRawFilePath dest) p vc
+ Remote.retrieveKeyFile r key f dest p vc
vc = Remote.RemoteVerify r
-- Download, not supporting canceling detected stalls.
else recordFailedTransfer t info
return v
- prep :: RawFilePath -> Maybe RawFilePath -> Annex () -> ModeSetter -> Annex (Maybe (LockHandle, Maybe LockHandle), Bool)
+ prep :: OsPath -> Maybe OsPath -> Annex () -> ModeSetter -> Annex (Maybe (LockHandle, Maybe LockHandle), Bool)
#ifndef mingw32_HOST_OS
prep lckfile moldlckfile createtfile mode = catchPermissionDenied (const prepfailed) $ do
- createAnnexDirectory $ P.takeDirectory lckfile
+ createAnnexDirectory $ takeDirectory lckfile
tryLockExclusive (Just mode) lckfile >>= \case
Nothing -> return (Nothing, True)
-- Since the lock file is removed in cleanup,
createtfile
return (Just (lockhandle, Nothing), False)
Just oldlckfile -> do
- createAnnexDirectory $ P.takeDirectory oldlckfile
+ createAnnexDirectory $ takeDirectory oldlckfile
tryLockExclusive (Just mode) oldlckfile >>= \case
Nothing -> do
liftIO $ dropLock lockhandle
)
#else
prep lckfile moldlckfile createtfile _mode = catchPermissionDenied (const prepfailed) $ do
- createAnnexDirectory $ P.takeDirectory lckfile
+ createAnnexDirectory $ takeDirectory lckfile
catchMaybeIO (liftIO $ lockExclusive lckfile) >>= \case
Just (Just lockhandle) -> case moldlckfile of
Nothing -> do
createtfile
return (Just (lockhandle, Nothing), False)
Just oldlckfile -> do
- createAnnexDirectory $ P.takeDirectory oldlckfile
+ createAnnexDirectory $ takeDirectory oldlckfile
catchMaybeIO (liftIO $ lockExclusive oldlckfile) >>= \case
Just (Just oldlockhandle) -> do
createtfile
cleanup _ _ _ Nothing = noop
cleanup tfile lckfile moldlckfile (Just (lockhandle, moldlockhandle)) = do
- void $ tryIO $ R.removeLink tfile
+ void $ tryIO $ removeFile tfile
#ifndef mingw32_HOST_OS
- void $ tryIO $ R.removeLink lckfile
- maybe noop (void . tryIO . R.removeLink) moldlckfile
+ void $ tryIO $ removeFile lckfile
+ maybe noop (void . tryIO . removeFile) moldlckfile
maybe noop dropLock moldlockhandle
dropLock lockhandle
#else
maybe noop dropLock moldlockhandle
dropLock lockhandle
void $ tryIO $ R.removeLink lckfile
- maybe noop (void . tryIO . R.removeLink) moldlckfile
+ maybe noop (void . tryIO . removeFile) moldlckfile
#endif
retry numretries oldinfo metervar run =
mkRunTransferrer :: BatchCommandMaker -> Annex RunTransferrer
mkRunTransferrer batchmaker = RunTransferrer
- <$> liftIO programPath
+ <$> liftIO (fromOsPath <$> programPath)
<*> gitAnnexChildProcessParams "transferrer" []
<*> pure batchmaker
Right r -> return r
Left err -> warning (UnquotedString err) >> return False
-download :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex Bool
+download :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> OsPath -> U.UrlOptions -> Annex Bool
download meterupdate iv url file uo =
liftIO (U.download meterupdate iv url file uo) >>= \case
Right () -> return True
Left err -> warning (UnquotedString err) >> return False
-download' :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex (Either String ())
+download' :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> OsPath -> U.UrlOptions -> Annex (Either String ())
download' meterupdate iv url file uo =
liftIO (U.download meterupdate iv url file uo)
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Annex.VariantFile where
import Annex.Common
import Utility.Hash
+import qualified Utility.OsString as OS
import qualified Data.ByteString as S
-variantMarker :: String
-variantMarker = ".variant-"
+variantMarker :: OsPath
+variantMarker = literalOsPath ".variant-"
-mkVariant :: FilePath -> String -> FilePath
+mkVariant :: OsPath -> OsPath -> OsPath
mkVariant file variant = takeDirectory file
</> dropExtension (takeFileName file)
- ++ variantMarker ++ variant
- ++ takeExtension file
+ <> variantMarker <> variant
+ <> takeExtension file
{- The filename to use when resolving a conflicted merge of a file,
- that points to a key.
- conflicted merge resolution code. That case is detected, and the full
- key is used in the filename.
-}
-variantFile :: FilePath -> Key -> FilePath
+variantFile :: OsPath -> Key -> OsPath
variantFile file key
- | doubleconflict = mkVariant file (fromRawFilePath (keyFile key))
- | otherwise = mkVariant file (shortHash $ serializeKey' key)
+ | doubleconflict = mkVariant file (keyFile key)
+ | otherwise = mkVariant file (toOsPath (shortHash $ serializeKey' key))
where
- doubleconflict = variantMarker `isInfixOf` file
+ doubleconflict = variantMarker `OS.isInfixOf` file
shortHash :: S.ByteString -> String
shortHash = take 4 . show . md5s
import Annex.WorkerPool
import Types.WorkerPool
import Types.Key
+import qualified Utility.FileIO as F
import Control.Concurrent.STM
import Control.Concurrent.Async
import qualified Data.ByteString as S
#if WITH_INOTIFY
import qualified System.INotify as INotify
-import qualified System.FilePath.ByteString as P
#endif
shouldVerify :: VerifyConfig -> Annex Bool
- If the RetrievalSecurityPolicy requires verification and the key's
- backend doesn't support it, the verification will fail.
-}
-verifyKeyContentPostRetrieval :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> RawFilePath -> Annex Bool
+verifyKeyContentPostRetrieval :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> OsPath -> Annex Bool
verifyKeyContentPostRetrieval rsp v verification k f = case (rsp, verification) of
(_, Verified) -> return True
(RetrievalVerifiableKeysSecure, _) -> ifM (isVerifiable k)
-- When possible, does an incremental verification, because that can be
-- faster. Eg, the VURL backend can need to try multiple checksums and only
-- with an incremental verification does it avoid reading files twice.
-verifyKeyContent :: Key -> RawFilePath -> Annex Bool
+verifyKeyContent :: Key -> OsPath -> Annex Bool
verifyKeyContent k f = verifyKeySize k f <&&> verifyKeyContent' k f
-- Does not verify size.
-verifyKeyContent' :: Key -> RawFilePath -> Annex Bool
+verifyKeyContent' :: Key -> OsPath -> Annex Bool
verifyKeyContent' k f =
Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
Nothing -> return True
iv <- mkiv k
showAction (UnquotedString (descIncrementalVerifier iv))
res <- liftIO $ catchDefaultIO Nothing $
- withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do
+ F.withBinaryFile f ReadMode $ \h -> do
feedIncrementalVerifier h iv
finalizeIncrementalVerifier iv
case res of
Just verifier -> verifier k f
(Nothing, Just verifier) -> verifier k f
-resumeVerifyKeyContent :: Key -> RawFilePath -> IncrementalVerifier -> Annex Bool
+resumeVerifyKeyContent :: Key -> OsPath -> IncrementalVerifier -> Annex Bool
resumeVerifyKeyContent k f iv = liftIO (positionIncrementalVerifier iv) >>= \case
Nothing -> fallback
Just endpos -> do
| otherwise = do
showAction (UnquotedString (descIncrementalVerifier iv))
liftIO $ catchDefaultIO (Just False) $
- withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do
+ F.withBinaryFile f ReadMode $ \h -> do
hSeek h AbsoluteSeek endpos
feedIncrementalVerifier h iv
finalizeIncrementalVerifier iv
where
chunk = 65536
-verifyKeySize :: Key -> RawFilePath -> Annex Bool
+verifyKeySize :: Key -> OsPath -> Annex Bool
verifyKeySize k f = case fromKey keySize k of
Just size -> do
size' <- liftIO $ catchDefaultIO 0 $ getFileSize f
-- and if the disk is slow, the reader may never catch up to the writer,
-- and the disk cache may never speed up reads. So this should only be
-- used when there's not a better way to incrementally verify.
-tailVerify :: Maybe IncrementalVerifier -> RawFilePath -> Annex a -> Annex a
+tailVerify :: Maybe IncrementalVerifier -> OsPath -> Annex a -> Annex a
tailVerify (Just iv) f writer = do
finished <- liftIO newEmptyTMVarIO
t <- liftIO $ async $ tailVerify' iv f finished
writer `finally` finishtail
tailVerify Nothing _ writer = writer
-tailVerify' :: IncrementalVerifier -> RawFilePath -> TMVar () -> IO ()
+tailVerify' :: IncrementalVerifier -> OsPath -> TMVar () -> IO ()
#if WITH_INOTIFY
tailVerify' iv f finished =
tryNonAsync go >>= \case
-- of resuming, and waiting for modification deals with such
-- situations.
inotifydirchange i cont =
- INotify.addWatch i [INotify.Modify] dir $ \case
+ INotify.addWatch i [INotify.Modify] (fromOsPath dir) $ \case
-- Ignore changes to other files in the directory.
INotify.Modified { INotify.maybeFilePath = fn }
- | fn == Just basef -> cont
+ | fn == Just basef' -> cont
_ -> noop
where
- (dir, basef) = P.splitFileName f
+ (dir, basef) = splitFileName f
+ basef' = fromOsPath basef
- inotifyfilechange i = INotify.addWatch i [INotify.Modify] f . const
+ inotifyfilechange i = INotify.addWatch i [INotify.Modify] (fromOsPath f) . const
go = INotify.withINotify $ \i -> do
modified <- newEmptyTMVarIO
case v of
Just () -> do
r <- tryNonAsync $
- tryWhenExists (openBinaryFile (fromRawFilePath f) ReadMode) >>= \case
+ tryWhenExists (F.openBinaryFile f ReadMode) >>= \case
Just h -> return (Just h)
-- File does not exist, must have been
-- deleted. Wait for next modification
import Utility.Glob
import Types.Command
import CmdLine.Action
-import qualified Utility.RawFilePath as R
+import qualified Utility.OsString as OS
import qualified Data.Text as T
import qualified Data.ByteString as B
import qualified Data.Set as S
import qualified Data.Map as M
-import qualified System.FilePath.ByteString as P
import Control.Concurrent.Async
import "mtl" Control.Monad.Writer
- evaluate this function with the view parameter and reuse
- the result. The globs in the view will then be compiled and memoized.
-}
-viewedFiles :: View -> MkViewedFile -> FilePath -> MetaData -> [ViewedFile]
+viewedFiles :: View -> MkViewedFile -> OsPath -> MetaData -> [ViewedFile]
viewedFiles view =
let matchers = map viewComponentMatcher (viewComponents view)
in \mkviewedfile file metadata ->
then []
else
let paths = pathProduct $
- map (map toviewpath) (visible matches)
+ map (map (toOsPath . toviewpath))
+ (visible matches)
in if null paths
then [mkviewedfile file]
else map (</> mkviewedfile file) paths
prop_viewPath_roundtrips :: MetaValue -> Bool
prop_viewPath_roundtrips v = fromViewPath (toViewPath v) == v
-pathProduct :: [[FilePath]] -> [FilePath]
+pathProduct :: [[OsPath]] -> [OsPath]
pathProduct [] = []
pathProduct (l:ls) = foldl combinel l ls
where
filter (not . isviewunset) (zip visible values)
visible = filter viewVisible (viewComponents view)
paths = splitDirectories (dropFileName f)
- values = map (S.singleton . fromViewPath) paths
+ values = map (S.singleton . fromViewPath . fromOsPath) paths
MetaData derived = getViewedFileMetaData f
convfield (vc, v) = (viewField vc, v)
prop_view_roundtrips :: AssociatedFile -> MetaData -> Bool -> Bool
prop_view_roundtrips (AssociatedFile Nothing) _ _ = True
prop_view_roundtrips (AssociatedFile (Just f)) metadata visible = or
- [ B.null (P.takeFileName f) && B.null (P.takeDirectory f)
+ [ OS.null (takeFileName f) && OS.null (takeDirectory f)
, viewTooLarge view
- , all hasfields (viewedFiles view (viewedFileFromReference' Nothing Nothing) (fromRawFilePath f) metadata)
+ , all hasfields (viewedFiles view (viewedFileFromReference' Nothing Nothing) f metadata)
]
where
view = View (Git.Ref "foo") $
- Note that this may generate MetaFields that legalField rejects.
- This is necessary to have a 1:1 mapping between directory names and
- fields. So this MetaData cannot safely be serialized. -}
-getDirMetaData :: FilePath -> MetaData
+getDirMetaData :: OsPath -> MetaData
getDirMetaData d = MetaData $ M.fromList $ zip fields values
where
dirs = splitDirectories d
- fields = map (mkMetaFieldUnchecked . T.pack . addTrailingPathSeparator . joinPath)
+ fields = map (mkMetaFieldUnchecked . T.pack . fromOsPath . addTrailingPathSeparator . joinPath)
(inits dirs)
values = map (S.singleton . toMetaValue . encodeBS . fromMaybe "" . headMaybe)
- (tails dirs)
+ (tails (map fromOsPath dirs))
-getWorkTreeMetaData :: FilePath -> MetaData
+getWorkTreeMetaData :: OsPath -> MetaData
getWorkTreeMetaData = getDirMetaData . dropFileName
-getViewedFileMetaData :: FilePath -> MetaData
+getViewedFileMetaData :: OsPath -> MetaData
getViewedFileMetaData = getDirMetaData . dirFromViewedFile . takeFileName
{- Applies a view to the currently checked out branch, generating a new
- Look up the metadata of annexed files, and generate any ViewedFiles,
- and stage them.
-}
-applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Maybe Adjustment -> Annex Git.Branch
+applyView' :: MkViewedFile -> (OsPath -> MetaData) -> View -> Maybe Adjustment -> Annex Git.Branch
applyView' mkviewedfile getfilemetadata view madj = do
top <- fromRepo Git.repoPath
(l, clean) <- inRepo $ Git.LsFiles.inRepoDetails [] [top]
applyView''
:: MkViewedFile
- -> (FilePath -> MetaData)
+ -> (OsPath -> MetaData)
-> View
-> Maybe Adjustment
-> [t]
-- Git.UpdateIndex.streamUpdateIndex'
-- here would race with process's calls
-- to it.
- | "." `B.isPrefixOf` getTopFilePath topf ->
- feed "dummy"
+ | literalOsPath "." `OS.isPrefixOf` getTopFilePath topf ->
+ feed (literalOsPath "dummy")
| otherwise -> noop
getmetadata gc mdfeeder mdcloser ts
process uh mdreader = liftIO mdreader >>= \case
Just ((topf, _, mtreeitemtype, Just k), mdlog) -> do
let metadata = maybe emptyMetaData parseCurrentMetaData mdlog
- let f = fromRawFilePath $ getTopFilePath topf
+ let f = getTopFilePath topf
let metadata' = getfilemetadata f `unionMetaData` metadata
forM_ (genviewedfiles f metadata') $ \fv -> do
- f' <- fromRepo (fromTopFilePath $ asTopFilePath $ toRawFilePath fv)
+ f' <- fromRepo (fromTopFilePath $ asTopFilePath fv)
stagefile uh f' k mtreeitemtype
process uh mdreader
Just ((topf, sha, Just treeitemtype, Nothing), _) -> do
_ -> stagesymlink uh f k
stagesymlink uh f k = do
- linktarget <- calcRepo (gitAnnexLink f k)
+ linktarget <- fromOsPath <$> calcRepo (gitAnnexLink f k)
sha <- hashSymlink linktarget
liftIO . Git.UpdateIndex.streamUpdateIndex' uh
=<< inRepo (Git.UpdateIndex.stageSymlink f sha)
=<< catKey (DiffTree.dstsha item)
| otherwise = noop
handlechange item a = maybe noop
- (void . commandAction . a (fromRawFilePath $ getTopFilePath $ DiffTree.file item))
+ (void . commandAction . a (getTopFilePath $ DiffTree.file item))
{- Runs an action using the view index file.
- Note that the file does not necessarily exist, or can contain
withNewViewIndex :: Annex a -> Annex a
withNewViewIndex a = do
- liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexViewIndex
+ liftIO . removeWhenExistsWith removeFile
+ =<< fromRepo gitAnnexViewIndex
withViewIndex a
{- Generates a branch for a view, using the view index file
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Annex.View.ViewedFile (
import Annex.Common
import Utility.QuickCheck
import Backend.Utilities (maxExtensions)
+import qualified Utility.OsString as OS
import qualified Data.ByteString as S
-type FileName = String
-type ViewedFile = FileName
+type ViewedFile = OsPath
-type MkViewedFile = FilePath -> ViewedFile
+type MkViewedFile = OsPath -> ViewedFile
{- Converts a filepath used in a reference branch to the
- filename that will be used in the view.
(annexMaxExtensions g)
viewedFileFromReference' :: Maybe Int -> Maybe Int -> MkViewedFile
-viewedFileFromReference' maxextlen maxextensions f = concat $
- [ escape (fromRawFilePath base')
- , if null dirs then "" else "_%" ++ intercalate "%" (map escape dirs) ++ "%"
+viewedFileFromReference' maxextlen maxextensions f = toOsPath $ concat $
+ [ escape (fromOsPath base')
+ , if null dirs
+ then ""
+ else "_%" ++ intercalate "%" (map (escape . fromOsPath) dirs) ++ "%"
, escape $ fromRawFilePath $ S.concat extensions'
]
where
(path, basefile) = splitFileName f
- dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path)
+ dirs = filter (/= literalOsPath ".") $
+ map dropTrailingPathSeparator (splitPath path)
(base, extensions) = case maxextlen of
- Nothing -> splitShortExtensions (toRawFilePath basefile')
- Just n -> splitShortExtensions' (n+1) (toRawFilePath basefile')
+ Nothing -> splitShortExtensions basefile'
+ Just n -> splitShortExtensions' (n+1) basefile'
{- Limit number of extensions. -}
maxextensions' = fromMaybe maxExtensions maxextensions
(base', extensions')
| length extensions <= maxextensions' = (base, extensions)
| otherwise =
let (es,more) = splitAt maxextensions' (reverse extensions)
- in (base <> mconcat (reverse more), reverse es)
+ in (base <> toOsPath (mconcat (reverse more)), reverse es)
{- On Windows, if the filename looked like "dir/c:foo" then
- basefile would look like it contains a drive letter, which will
- not work. There cannot really be a filename like that, probably,
{- Extracts from a ViewedFile the directory where the file is located on
- in the reference branch. -}
-dirFromViewedFile :: ViewedFile -> FilePath
-dirFromViewedFile = joinPath . drop 1 . sep [] ""
+dirFromViewedFile :: ViewedFile -> OsPath
+dirFromViewedFile = joinPath . map toOsPath . drop 1 . sep [] "" . fromOsPath
where
sep l _ [] = reverse l
sep l curr (c:cs)
prop_viewedFile_roundtrips :: TestableFilePath -> Bool
prop_viewedFile_roundtrips tf
-- Relative filenames wanted, not directories.
- | any (isPathSeparator) (end f ++ beginning f) = True
- | isAbsolute f || isDrive f = True
+ | OS.any isPathSeparator (toOsPath (end f ++ beginning f)) = True
+ | isAbsolute (toOsPath f) || isDrive (toOsPath f) = True
| otherwise = dir == dirFromViewedFile
- (viewedFileFromReference' Nothing Nothing f)
+ (viewedFileFromReference' Nothing Nothing (toOsPath f))
where
f = fromTestableFilePath tf
- dir = joinPath $ beginning $ splitDirectories f
+ dir = joinPath $ beginning $ splitDirectories (toOsPath f)
- When in an adjusted branch that may have hidden the file, looks for a
- pointer to a key in the original branch.
-}
-lookupKey :: RawFilePath -> Annex (Maybe Key)
+lookupKey :: OsPath -> Annex (Maybe Key)
lookupKey = lookupKey' catkeyfile
where
catkeyfile file =
- ifM (liftIO $ doesFileExist $ fromRawFilePath file)
+ ifM (liftIO $ doesFileExist file)
( catKeyFile file
, catKeyFileHidden file =<< getCurrentBranch
)
- changes in the work tree. This means it's slower, but it also has
- consistently the same behavior for locked files as for unlocked files.
-}
-lookupKeyStaged :: RawFilePath -> Annex (Maybe Key)
+lookupKeyStaged :: OsPath -> Annex (Maybe Key)
lookupKeyStaged file = catKeyFile file >>= \case
Just k -> return (Just k)
Nothing -> catKeyFileHidden file =<< getCurrentBranch
{- Like lookupKey, but does not find keys for hidden files. -}
-lookupKeyNotHidden :: RawFilePath -> Annex (Maybe Key)
+lookupKeyNotHidden :: OsPath -> Annex (Maybe Key)
lookupKeyNotHidden = lookupKey' catkeyfile
where
catkeyfile file =
- ifM (liftIO $ doesFileExist $ fromRawFilePath file)
+ ifM (liftIO $ doesFileExist file)
( catKeyFile file
, return Nothing
)
-lookupKey' :: (RawFilePath -> Annex (Maybe Key)) -> RawFilePath -> Annex (Maybe Key)
+lookupKey' :: (OsPath -> Annex (Maybe Key)) -> OsPath -> Annex (Maybe Key)
lookupKey' catkeyfile file = isAnnexLink file >>= \case
Just key -> return (Just key)
Nothing -> catkeyfile file
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module Annex.YoutubeDl (
import Utility.Tmp
import Messages.Progress
import Logs.Transfer
-import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import Network.URI
-- (This can fail, but youtube-dl is deprecated, and they closed my
-- issue requesting something like --print-to-file;
-- <https://github.com/rg3/youtube-dl/issues/14864>)
-youtubeDl :: URLString -> FilePath -> MeterUpdate -> Annex (Either String (Maybe FilePath))
+youtubeDl :: URLString -> OsPath -> MeterUpdate -> Annex (Either String (Maybe OsPath))
youtubeDl url workdir p = ifM ipAddressesUnlimited
( withUrlOptions $ youtubeDl' url workdir p
, return $ Left youtubeDlNotAllowedMessage
)
-youtubeDl' :: URLString -> FilePath -> MeterUpdate -> UrlOptions -> Annex (Either String (Maybe FilePath))
+youtubeDl' :: URLString -> OsPath -> MeterUpdate -> UrlOptions -> Annex (Either String (Maybe OsPath))
youtubeDl' url workdir p uo
| supportedScheme uo url = do
cmd <- youtubeDlCommand
ifM (liftIO $ inSearchPath cmd)
( runcmd cmd >>= \case
Right True -> downloadedfiles cmd >>= \case
- (f:[]) -> return (Right (Just f))
+ (f:[]) -> return $
+ Right (Just (toOsPath f))
[] -> return (nofiles cmd)
fs -> return (toomanyfiles cmd fs)
Right False -> workdirfiles >>= \case
toomanyfiles cmd fs = Left $ cmd ++ " downloaded multiple media files; git-annex is only able to deal with one per url: " ++ show fs
downloadedfiles cmd
| isytdlp cmd = liftIO $
- (nub . lines <$> readFile filelistfile)
+ (nub . lines <$> readFile (fromOsPath filelistfile))
`catchIO` (pure . const [])
- | otherwise = map fromRawFilePath <$> workdirfiles
- workdirfiles = liftIO $ filter (/= toRawFilePath filelistfile)
- <$> (filterM R.doesPathExist =<< dirContents (toRawFilePath workdir))
+ | otherwise = map fromOsPath <$> workdirfiles
+ workdirfiles = liftIO $ filter (/= filelistfile)
+ <$> (filterM doesFileExist =<< dirContents workdir)
filelistfile = workdir </> filelistfilebase
- filelistfilebase = "git-annex-file-list-file"
+ filelistfilebase = literalOsPath "git-annex-file-list-file"
isytdlp cmd = cmd == "yt-dlp"
runcmd cmd = youtubeDlMaxSize workdir >>= \case
Left msg -> return (Left msg)
liftIO $ commandMeter'
(if isytdlp cmd then parseYtdlpProgress else parseYoutubeDlProgress)
oh (Just meter) meterupdate cmd opts
- (\pr -> pr { cwd = Just workdir })
+ (\pr -> pr { cwd = Just (fromOsPath workdir) })
return (Right ok)
dlopts cmd =
[ Param url
, Param progressTemplate
, Param "--print-to-file"
, Param "after_move:filepath"
- , Param filelistfilebase
+ , Param (fromOsPath filelistfilebase)
]
else []
-- large a media file. Factors in other downloads that are in progress,
-- and any files in the workdir that it may have partially downloaded
-- before.
-youtubeDlMaxSize :: FilePath -> Annex (Either String [CommandParam])
+youtubeDlMaxSize :: OsPath -> Annex (Either String [CommandParam])
youtubeDlMaxSize workdir = ifM (Annex.getRead Annex.force)
( return $ Right []
- , liftIO (getDiskFree workdir) >>= \case
+ , liftIO (getDiskFree (fromOsPath workdir)) >>= \case
Just have -> do
inprogress <- sizeOfDownloadsInProgress (const True)
partial <- liftIO $ sum
- <$> (mapM getFileSize =<< dirContents (toRawFilePath workdir))
+ <$> (mapM getFileSize =<< dirContents workdir)
reserve <- annexDiskReserve <$> Annex.getGitConfig
let maxsize = have - reserve - inprogress + partial
if maxsize > 0
)
-- Download a media file to a destination,
-youtubeDlTo :: Key -> URLString -> FilePath -> MeterUpdate -> Annex Bool
+youtubeDlTo :: Key -> URLString -> OsPath -> MeterUpdate -> Annex Bool
youtubeDlTo key url dest p = do
res <- withTmpWorkDir key $ \workdir ->
- youtubeDl url (fromRawFilePath workdir) p >>= \case
+ youtubeDl url workdir p >>= \case
Right (Just mediafile) -> do
- liftIO $ moveFile (toRawFilePath mediafile) (toRawFilePath dest)
+ liftIO $ moveFile mediafile dest
return (Just True)
Right Nothing -> return (Just False)
Left msg -> do
-- Ask youtube-dl for the filename of media in an url.
--
-- (This is not always identical to the filename it uses when downloading.)
-youtubeDlFileName :: URLString -> Annex (Either String FilePath)
+youtubeDlFileName :: URLString -> Annex (Either String OsPath)
youtubeDlFileName url = withUrlOptions go
where
go uo
-- Does not check if the url contains htmlOnly; use when that's already
-- been verified.
-youtubeDlFileNameHtmlOnly :: URLString -> Annex (Either String FilePath)
+youtubeDlFileNameHtmlOnly :: URLString -> Annex (Either String OsPath)
youtubeDlFileNameHtmlOnly = withUrlOptions . youtubeDlFileNameHtmlOnly'
-youtubeDlFileNameHtmlOnly' :: URLString -> UrlOptions -> Annex (Either String FilePath)
+youtubeDlFileNameHtmlOnly' :: URLString -> UrlOptions -> Annex (Either String OsPath)
youtubeDlFileNameHtmlOnly' url uo
| supportedScheme uo url = flip catchIO (pure . Left . show) go
| otherwise = return nomedia
ok <- liftIO $ checkSuccessProcess pid
wait errt
return $ case (ok, lines output) of
- (True, (f:_)) | not (null f) -> Right f
+ (True, (f:_)) | not (null f) -> Right (toOsPath f)
_ -> nomedia
waitproc _ _ _ _ = error "internal"
else return $ Left $ "Scraping needs yt-dlp, but git-annex has been configured to use " ++ cmd
youtubePlaylist' :: URLString -> String -> IO (Either String [YoutubePlaylistItem])
-youtubePlaylist' url cmd = withTmpFile (toOsPath (toRawFilePath "yt-dlp")) $ \tmpfile h -> do
+youtubePlaylist' url cmd = withTmpFile (literalOsPath "yt-dlp") $ \tmpfile h -> do
hClose h
(outerr, ok) <- processTranscript cmd
[ "--simulate"
, "--print-to-file"
-- Write json with selected fields.
, "%(.{" ++ intercalate "," youtubePlaylistItemFields ++ "})j"
- , fromRawFilePath (fromOsPath tmpfile)
+ , fromOsPath tmpfile
, url
]
Nothing
instance Aeson.FromJSON YoutubePlaylistItem
where
parseJSON = Aeson.genericParseJSON Aeson.defaultOptions
- { Aeson.fieldLabelModifier = drop (length "youtube_") }
-
+ { Aeson.fieldLabelModifier =
+ drop (length ("youtube_" :: String))
+ }
import Network.Socket (HostName, PortNumber)
stopDaemon :: Annex ()
-stopDaemon = liftIO . Utility.Daemon.stopDaemon . fromRawFilePath
- =<< fromRepo gitAnnexPidFile
+stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
{- Starts the daemon. If the daemon is run in the foreground, once it's
- running, can start the browser.
-
- startbrowser is passed the url and html shim file, as well as the original
- stdout and stderr descriptors. -}
-startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName -> Maybe PortNumber -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
+startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName -> Maybe PortNumber -> Maybe (Maybe Handle -> Maybe Handle -> String -> OsPath -> IO ()) -> Annex ()
startDaemon assistant foreground startdelay cannotrun listenhost listenport startbrowser = do
Annex.changeState $ \s -> s { Annex.daemon = True }
enableInteractiveBranchAccess
pidfile <- fromRepo gitAnnexPidFile
logfile <- fromRepo gitAnnexDaemonLogFile
- liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromRawFilePath logfile
+ liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromOsPath logfile
createAnnexDirectory (parentDir pidfile)
#ifndef mingw32_HOST_OS
createAnnexDirectory (parentDir logfile)
- let logfd = handleToFd =<< openLog (fromRawFilePath logfile)
+ let logfd = handleToFd =<< openLog (fromOsPath logfile)
if foreground
then do
origout <- liftIO $ catchMaybeIO $
fdToHandle =<< dup stdOutput
origerr <- liftIO $ catchMaybeIO $
fdToHandle =<< dup stdError
- let undaemonize = Utility.Daemon.foreground logfd (Just (fromRawFilePath pidfile))
+ let undaemonize = Utility.Daemon.foreground logfd (Just pidfile)
start undaemonize $
case startbrowser of
Nothing -> Nothing
Just a -> Just $ a origout origerr
else do
- git_annex <- liftIO programPath
+ git_annex <- fromOsPath <$> liftIO programPath
ps <- gitAnnexDaemonizeParams
- start (Utility.Daemon.daemonize git_annex ps logfd (Just (fromRawFilePath pidfile)) False) Nothing
+ start (Utility.Daemon.daemonize git_annex ps logfd (Just pidfile) False) Nothing
#else
-- Windows doesn't daemonize, but does redirect output to the
-- log file. The only way to do so is to restart the program.
createAnnexDirectory (parentDir logfile)
ifM (liftIO $ isNothing <$> getEnv flag)
( liftIO $ withNullHandle $ \nullh -> do
- loghandle <- openLog (fromRawFilePath logfile)
+ loghandle <- openLog (fromOsPath logfile)
e <- getEnvironment
cmd <- programPath
ps <- getArgs
exitcode <- withCreateProcess p $ \_ _ _ pid ->
waitForProcess pid
exitWith exitcode
- , start (Utility.Daemon.foreground (Just (fromRawFilePath pidfile))) $
+ , start (Utility.Daemon.foreground (Just (fromOsPath pidfile))) $
case startbrowser of
Nothing -> Nothing
Just a -> Just $ a Nothing Nothing
checkCanWatch
dstatus <- startDaemonStatus
logfile <- fromRepo gitAnnexDaemonLogFile
- liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromRawFilePath logfile
+ liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromOsPath logfile
liftIO $ daemonize $
flip runAssistant (go webappwaiter)
=<< newAssistantData st dstatus
maxfilesshown = 10
(!somefiles, !counter) = splitcounter (dedupadjacent files)
- !shortfiles = map (fromString . shortFile . takeFileName) somefiles
+ !shortfiles = map (fromString . shortFile . fromOsPath . takeFileName . toOsPath) somefiles
renderer alert = tenseWords $ msg : alertData alert ++ showcounter
where
import Control.Concurrent.STM
{- Handlers call this when they made a change that needs to get committed. -}
-madeChange :: FilePath -> ChangeInfo -> Assistant (Maybe Change)
+madeChange :: OsPath -> ChangeInfo -> Assistant (Maybe Change)
madeChange f t = Just <$> (Change <$> liftIO getCurrentTime <*> pure f <*> pure t)
noChange :: Assistant (Maybe Change)
noChange = return Nothing
{- Indicates an add needs to be done, but has not started yet. -}
-pendingAddChange :: FilePath -> Assistant (Maybe Change)
+pendingAddChange :: OsPath -> Assistant (Maybe Change)
pendingAddChange f = Just <$> (PendingAddChange <$> liftIO getCurrentTime <*> pure f)
{- Gets all unhandled changes.
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Assistant.Install where
import System.PosixCompat.Files (ownerExecuteMode)
import qualified Data.ByteString.Char8 as S8
-standaloneAppBase :: IO (Maybe FilePath)
-standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE"
+standaloneAppBase :: IO (Maybe OsPath)
+standaloneAppBase = fmap toOsPath <$> getEnv "GIT_ANNEX_APP_BASE"
{- The standalone app does not have an installation process.
- So when it's run, it needs to set up autostarting of the assistant
, go =<< standaloneAppBase
)
where
- go Nothing = installFileManagerHooks "git-annex"
+ go Nothing = installFileManagerHooks (literalOsPath "git-annex")
go (Just base) = do
- let program = base </> "git-annex"
+ let program = base </> literalOsPath "git-annex"
programfile <- programFile
- createDirectoryIfMissing True $
- fromRawFilePath (parentDir (toRawFilePath programfile))
- writeFile programfile program
+ createDirectoryIfMissing True (parentDir programfile)
+ writeFile (fromOsPath programfile) (fromOsPath program)
#ifdef darwin_HOST_OS
autostartfile <- userAutoStart osxAutoStartLabel
( do
-- Integration with the Termux:Boot app.
home <- myHomeDir
- let bootfile = home </> ".termux" </> "boot" </> "git-annex"
+ let bootfile = toOsPath home </> literalOsPath ".termux" </> literalOsPath "boot" </> literalOsPath "git-annex"
unlessM (doesFileExist bootfile) $ do
createDirectoryIfMissing True (takeDirectory bootfile)
- writeFile bootfile "git-annex assistant --autostart"
+ writeFile (fromOsPath bootfile) "git-annex assistant --autostart"
, do
menufile <- desktopMenuFilePath "git-annex" <$> userDataDir
icondir <- iconDir <$> userDataDir
- installMenu program menufile base icondir
+ installMenu (fromOsPath program) menufile base icondir
autostartfile <- autoStartPath "git-annex" <$> userConfigDir
- installAutoStart program autostartfile
+ installAutoStart (fromOsPath program) autostartfile
)
#endif
sshdir <- sshDir
- let runshell var = "exec " ++ base </> "runshell " ++ var
+ let runshell var = "exec " ++ fromOsPath (base </> literalOsPath "runshell ") ++ var
let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\""
- installWrapper (toRawFilePath (sshdir </> "git-annex-shell")) $
+ installWrapper (sshdir </> literalOsPath "git-annex-shell") $
[ shebang
, "set -e"
, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
, rungitannexshell "$@"
, "fi"
]
- installWrapper (toRawFilePath (sshdir </> "git-annex-wrapper")) $
+ installWrapper (sshdir </> literalOsPath "git-annex-wrapper") $
[ shebang
, "set -e"
, runshell "\"$@\""
installFileManagerHooks program
-installWrapper :: RawFilePath -> [String] -> IO ()
+installWrapper :: OsPath -> [String] -> IO ()
installWrapper file content = do
let content' = map encodeBS content
- curr <- catchDefaultIO [] $ fileLines' <$> F.readFile' (toOsPath file)
+ curr <- catchDefaultIO [] $ fileLines' <$> F.readFile' file
when (curr /= content') $ do
- createDirectoryIfMissing True (fromRawFilePath (parentDir file))
- viaTmp F.writeFile' (toOsPath file) $
- linesFile' (S8.unlines content')
+ createDirectoryIfMissing True (parentDir file)
+ viaTmp F.writeFile' file $ linesFile' (S8.unlines content')
modifyFileMode file $ addModes [ownerExecuteMode]
-installFileManagerHooks :: FilePath -> IO ()
+installFileManagerHooks :: OsPath -> IO ()
#ifdef linux_HOST_OS
installFileManagerHooks program = unlessM osAndroid $ do
let actions = ["get", "drop", "undo"]
-- Gnome
- nautilusScriptdir <- (\d -> d </> "nautilus" </> "scripts") <$> userDataDir
+ nautilusScriptdir <- (\d -> d </> literalOsPath "nautilus" </> literalOsPath "scripts") <$> userDataDir
createDirectoryIfMissing True nautilusScriptdir
forM_ actions $
genNautilusScript nautilusScriptdir
-- KDE
userdata <- userDataDir
- let kdeServiceMenusdir = userdata </> "kservices5" </> "ServiceMenus"
+ let kdeServiceMenusdir = userdata </> literalOsPath "kservices5" </> literalOsPath "ServiceMenus"
createDirectoryIfMissing True kdeServiceMenusdir
- writeFile (kdeServiceMenusdir </> "git-annex.desktop")
+ writeFile (fromOsPath (kdeServiceMenusdir </> literalOsPath "git-annex.desktop"))
(kdeDesktopFile actions)
where
genNautilusScript scriptdir action =
- installscript (toRawFilePath (scriptdir </> scriptname action)) $ unlines
+ installscript (scriptdir </> toOsPath (scriptname action)) $ unlines
[ shebang
, autoaddedcomment
- , "exec " ++ program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\""
+ , "exec " ++ fromOsPath program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\""
]
scriptname action = "git-annex " ++ action
installscript f c = whenM (safetoinstallscript f) $ do
- writeFile (fromRawFilePath f) c
+ writeFile (fromOsPath f) c
modifyFileMode f $ addModes [ownerExecuteMode]
safetoinstallscript f = catchDefaultIO True $
elem (encodeBS autoaddedcomment) . fileLines'
- <$> F.readFile' (toOsPath f)
+ <$> F.readFile' f
autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)"
autoaddedmsg = "Automatically added by git-annex, do not edit."
, "Icon=git-annex"
, unwords
[ "Exec=sh -c 'cd \"$(dirname \"$1\")\" &&"
- , program
+ , fromOsPath program
, command
, "--notify-start --notify-finish -- \"$1\"'"
, "false" -- this becomes $0 in sh, so unused
module Assistant.Install.AutoStart where
+import Common
import Utility.FreeDesktop
#ifdef darwin_HOST_OS
import Utility.OSX
import Utility.FileSystemEncoding
#endif
-installAutoStart :: FilePath -> FilePath -> IO ()
+installAutoStart :: String -> OsPath -> IO ()
installAutoStart command file = do
#ifdef darwin_HOST_OS
- createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath file)))
- writeFile file $ genOSXAutoStartFile osxAutoStartLabel command
+ createDirectoryIfMissing True (parentDir file)
+ writeFile (fromOsPath file) $ genOSXAutoStartFile osxAutoStartLabel command
["assistant", "--autostart"]
#else
writeDesktopMenuFile (fdoAutostart command) file
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Assistant.Install.Menu where
+import Common
import Utility.FreeDesktop
-import Utility.FileSystemEncoding
-import Utility.Path
-import System.IO
-import Utility.SystemDirectory
-#ifndef darwin_HOST_OS
-import System.FilePath
-#endif
-
-installMenu :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()
+installMenu :: String -> OsPath -> OsPath -> OsPath -> IO ()
#ifdef darwin_HOST_OS
installMenu _command _menufile _iconsrcdir _icondir = return ()
#else
installMenu command menufile iconsrcdir icondir = do
writeDesktopMenuFile (fdoDesktopMenu command) menufile
- installIcon (iconsrcdir </> "logo.svg") $
- iconFilePath (iconBaseName ++ ".svg") "scalable" icondir
- installIcon (iconsrcdir </> "logo_16x16.png") $
- iconFilePath (iconBaseName ++ ".png") "16x16" icondir
+ installIcon (iconsrcdir </> literalOsPath "logo.svg") $
+ iconFilePath (toOsPath (iconBaseName ++ ".svg")) "scalable" icondir
+ installIcon (iconsrcdir </> literalOsPath "logo_16x16.png") $
+ iconFilePath (toOsPath (iconBaseName ++ ".png")) "16x16" icondir
#endif
{- The command can be either just "git-annex", or the full path to use
(Just iconBaseName)
["Network", "FileTransfer"]
-installIcon :: FilePath -> FilePath -> IO ()
+installIcon :: OsPath -> OsPath -> IO ()
installIcon src dest = do
- createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath dest)))
- withBinaryFile src ReadMode $ \hin ->
- withBinaryFile dest WriteMode $ \hout ->
+ createDirectoryIfMissing True (parentDir dest)
+ withBinaryFile (fromOsPath src) ReadMode $ \hin ->
+ withBinaryFile (fromOsPath dest) WriteMode $ \hout ->
hGetContents hin >>= hPutStr hout
iconBaseName :: String
{- Makes a new git repository. Or, if a git repository already
- exists, returns False. -}
-makeRepo :: FilePath -> Bool -> IO Bool
+makeRepo :: OsPath -> Bool -> IO Bool
makeRepo path bare = ifM (probeRepoExists path)
( return False
, do
where
baseparams = [Param "init", Param "--quiet"]
params
- | bare = baseparams ++ [Param "--bare", File path]
- | otherwise = baseparams ++ [File path]
+ | bare = baseparams ++ [Param "--bare", File (fromOsPath path)]
+ | otherwise = baseparams ++ [File (fromOsPath path)]
{- Runs an action in the git repository in the specified directory. -}
-inDir :: FilePath -> Annex a -> IO a
+inDir :: OsPath -> Annex a -> IO a
inDir dir a = do
state <- Annex.new
=<< Git.Config.read
- =<< Git.Construct.fromPath (toRawFilePath dir)
+ =<< Git.Construct.fromPath dir
Annex.eval state $ a `finally` quiesce True
{- Creates a new repository, and returns its UUID. -}
-initRepo :: Bool -> Bool -> FilePath -> Maybe String -> Maybe StandardGroup -> IO UUID
+initRepo :: Bool -> Bool -> OsPath -> Maybe String -> Maybe StandardGroup -> IO UUID
initRepo True primary_assistant_repo dir desc mgroup = inDir dir $ do
initRepo' desc mgroup
{- Initialize the master branch, so things that expect
Annex.Branch.commit =<< Annex.Branch.commitMessage
{- Checks if a git repo exists at a location. -}
-probeRepoExists :: FilePath -> IO Bool
+probeRepoExists :: OsPath -> IO Bool
probeRepoExists dir = isJust <$>
- catchDefaultIO Nothing (Git.Construct.checkForRepo (encodeBS dir))
+ catchDefaultIO Nothing (Git.Construct.checkForRepo dir)
{- Authorized keys are set up before pairing is complete, so that the other
- side can immediately begin syncing. -}
-setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
+setupAuthorizedKeys :: PairMsg -> OsPath -> IO ()
setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of
Left err -> giveup err
Right pubkey -> do
- absdir <- fromRawFilePath <$> absPath (toRawFilePath repodir)
+ absdir <- absPath repodir
unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $
giveup "failed setting up ssh authorized keys"
{ sshHostName = T.pack hostname
, sshUserName = Just (T.pack $ remoteUserName d)
, sshDirectory = T.pack dir
- , sshRepoName = genSshRepoName hostname dir
+ , sshRepoName = genSshRepoName hostname (toOsPath dir)
, sshPort = 22
, needsPubKey = True
, sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable]
#endif
import qualified Utility.Lsof as Lsof
import Utility.ThreadScheduler
-import qualified Utility.RawFilePath as R
+import qualified Utility.OsString as OS
import Control.Concurrent.Async
-import qualified Data.ByteString as S
-import qualified System.FilePath.ByteString as P
{- When the FsckResults require a repair, tries to do a non-destructive
- repair. If that fails, pops up an alert. -}
thisrepopath <- liftIO . absPath
=<< liftAnnex (fromRepo Git.repoPath)
a <- liftAnnex $ mkrepair $
- repair fsckresults (Just (fromRawFilePath thisrepopath))
+ repair fsckresults (Just (fromOsPath thisrepopath))
liftIO $ catchBoolIO a
repair fsckresults referencerepo = do
backgroundfsck params = liftIO $ void $ async $ do
program <- programPath
- batchCommand program (Param "fsck" : params)
+ batchCommand (fromOsPath program) (Param "fsck" : params)
{- Detect when a git lock file exists and has no git process currently
- writing to it. This strongly suggests it is a stale lock file.
repairStaleLocks lockfiles
return $ not $ null lockfiles
where
- findgitfiles = dirContentsRecursiveSkipping (== P.dropTrailingPathSeparator annexDir) True . Git.localGitDir
+ findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir
islock f
- | "gc.pid" `S.isInfixOf` f = False
- | ".lock" `S.isSuffixOf` f = True
- | P.takeFileName f == "MERGE_HEAD" = True
+ | literalOsPath "gc.pid" `OS.isInfixOf` f = False
+ | literalOsPath ".lock" `OS.isSuffixOf` f = True
+ | takeFileName f == literalOsPath "MERGE_HEAD" = True
| otherwise = False
-repairStaleLocks :: [RawFilePath] -> Assistant ()
+repairStaleLocks :: [OsPath] -> Assistant ()
repairStaleLocks lockfiles = go =<< getsizes
where
getsize lf = catchMaybeIO $ (\s -> (lf, s))
<$> getFileSize lf
getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles
go [] = return ()
- go l = ifM (liftIO $ null <$> Lsof.query ("--" : map (fromRawFilePath . fst) l))
+ go l = ifM (liftIO $ null <$> Lsof.query ("--" : map (fromOsPath . fst) l))
( do
waitforit "to check stale git lock file"
l' <- getsizes
if l' == l
- then liftIO $ mapM_ (removeWhenExistsWith R.removeLink . fst) l
+ then liftIO $ mapM_ (removeWhenExistsWith removeFile . fst) l
else go l'
, do
waitforit "for git lock file writer"
import Utility.Url
import Utility.Url.Parse
import Utility.PID
-import qualified Utility.RawFilePath as R
import qualified Git.Construct
import qualified Git.Config
import qualified Annex
prepRestart :: Assistant ()
prepRestart = do
liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread
- liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexUrlFile)
- liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexPidFile)
+ liftIO . removeWhenExistsWith removeFile =<< liftAnnex (fromRepo gitAnnexUrlFile)
+ liftIO . removeWhenExistsWith removeFile =<< liftAnnex (fromRepo gitAnnexPidFile)
{- To finish a restart, send a global redirect to the new url
- to any web browsers that are displaying the webapp.
runRestart :: Assistant URLString
runRestart = liftIO . newAssistantUrl
- =<< liftAnnex (Git.repoLocation <$> Annex.gitRepo)
+ =<< liftAnnex (Git.repoPath <$> Annex.gitRepo)
{- Starts up the assistant in the repository, and waits for it to create
- a gitAnnexUrlFile. Waits for the assistant to be up and listening for
- connections by testing the url. -}
-newAssistantUrl :: FilePath -> IO URLString
+newAssistantUrl :: OsPath -> IO URLString
newAssistantUrl repo = do
startAssistant repo
geturl
where
geturl = do
- r <- Git.Config.read =<< Git.Construct.fromPath (toRawFilePath repo)
- waiturl $ fromRawFilePath $ gitAnnexUrlFile r
+ r <- Git.Config.read =<< Git.Construct.fromPath repo
+ waiturl $ gitAnnexUrlFile r
waiturl urlfile = do
- v <- tryIO $ readFile urlfile
+ v <- tryIO $ readFile (fromOsPath urlfile)
case v of
Left _ -> delayed $ waiturl urlfile
Right url -> ifM (assistantListening url)
- On windows, the assistant does not daemonize, which is why the forkIO is
- done.
-}
-startAssistant :: FilePath -> IO ()
+startAssistant :: OsPath -> IO ()
startAssistant repo = void $ forkIO $ do
- program <- programPath
- let p = (proc program ["assistant"]) { cwd = Just repo }
+ program <- fromOsPath <$> programPath
+ let p = (proc program ["assistant"]) { cwd = Just (fromOsPath repo) }
withCreateProcess p $ \_ _ _ pid -> void $ checkSuccessProcess pid
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Assistant.Ssh where
import Annex.Common
import Utility.SshHost
import Utility.Process.Transcript
import qualified Utility.FileIO as F
+import qualified Utility.OsString as OS
import Data.Text (Text)
import qualified Data.Text as T
{- Reverses genSshUrl -}
parseSshUrl :: String -> Maybe SshData
parseSshUrl u
- | "ssh://" `isPrefixOf` u = fromssh (drop (length "ssh://") u)
+ | "ssh://" `isPrefixOf` u = fromssh (drop (length ("ssh://" :: String)) u)
| otherwise = fromrsync u
where
mkdata (userhost, dir) = Just $ SshData
{ sshHostName = T.pack host
, sshUserName = if null user then Nothing else Just $ T.pack user
, sshDirectory = T.pack dir
- , sshRepoName = genSshRepoName host dir
+ , sshRepoName = genSshRepoName host (toOsPath dir)
-- dummy values, cannot determine from url
, sshPort = 22
, needsPubKey = True
fromssh = mkdata . break (== '/')
{- Generates a git remote name, like host_dir or host -}
-genSshRepoName :: String -> FilePath -> String
+genSshRepoName :: String -> OsPath -> String
genSshRepoName host dir
- | null dir = makeLegalName host
- | otherwise = makeLegalName $ host ++ "_" ++ dir
+ | OS.null dir = makeLegalName host
+ | otherwise = makeLegalName $ host ++ "_" ++ fromOsPath dir
{- The output of ssh, including both stdout and stderr. -}
sshTranscript :: [String] -> SshHost -> String -> (Maybe String) -> IO (String, Bool)
where
(ssh, keytype) = separate (== '-') prefix
-addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool
+addAuthorizedKeys :: Bool -> OsPath -> SshPubKey -> IO Bool
addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh"
[ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ]
{- Should only be used within the same process that added the line;
- the layout of the line is not kepy stable across versions. -}
-removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO ()
+removeAuthorizedKeys :: Bool -> OsPath -> SshPubKey -> IO ()
removeAuthorizedKeys gitannexshellonly dir pubkey = do
let keyline = authorizedKeysLine gitannexshellonly dir pubkey
sshdir <- sshDir
- let keyfile = toOsPath $ toRawFilePath $ sshdir </> "authorized_keys"
+ let keyfile = sshdir </> literalOsPath "authorized_keys"
tryWhenExists (map decodeBS . fileLines' <$> F.readFile' keyfile) >>= \case
Just ls -> viaTmp writeSshConfig keyfile $
unlines $ filter (/= keyline) ls
- The ~/.ssh/git-annex-shell wrapper script is created if not already
- present.
-}
-addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String
+addAuthorizedKeysCommand :: Bool -> OsPath -> SshPubKey -> String
addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&"
[ "mkdir -p ~/.ssh"
, intercalate "; "
]
runshell var = "exec git-annex-shell -c \"" ++ var ++ "\""
-authorizedKeysLine :: Bool -> FilePath -> SshPubKey -> String
+authorizedKeysLine :: Bool -> OsPath -> SshPubKey -> String
authorizedKeysLine gitannexshellonly dir pubkey
| gitannexshellonly = limitcommand ++ pubkey
{- TODO: Locking down rsync is difficult, requiring a rather
- long perl script. -}
| otherwise = pubkey
where
- limitcommand = "command=\"env GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty "
+ limitcommand = "command=\"env GIT_ANNEX_SHELL_DIRECTORY="++shellEscape (fromOsPath dir)++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty "
{- Generates a ssh key pair. -}
genSshKeyPair :: IO SshKeyPair
-genSshKeyPair = withTmpDir (toOsPath (toRawFilePath "git-annex-keygen")) $ \dir -> do
+genSshKeyPair = withTmpDir (literalOsPath "git-annex-keygen") $ \dir -> do
ok <- boolSystem "ssh-keygen"
[ Param "-P", Param "" -- no password
- , Param "-f", File $ dir </> "key"
+ , Param "-f", File $ fromOsPath (dir </> literalOsPath "key")
]
unless ok $
giveup "ssh-keygen failed"
SshKeyPair
- <$> readFile (dir </> "key.pub")
- <*> readFile (dir </> "key")
+ <$> readFile (fromOsPath (dir </> literalOsPath "key.pub"))
+ <*> readFile (fromOsPath (dir </> literalOsPath "key"))
{- Installs a ssh key pair, and sets up ssh config with a mangled hostname
- that will enable use of the key. This way we avoid changing the user's
installSshKeyPair :: SshKeyPair -> SshData -> IO SshData
installSshKeyPair sshkeypair sshdata = do
sshdir <- sshDir
- createDirectoryIfMissing True $ fromRawFilePath $
- parentDir $ toRawFilePath $ sshdir </> sshPrivKeyFile sshdata
+ createDirectoryIfMissing True $
+ parentDir $ sshdir </> sshPrivKeyFile sshdata
unlessM (doesFileExist $ sshdir </> sshPrivKeyFile sshdata) $
- writeFileProtected (toRawFilePath (sshdir </> sshPrivKeyFile sshdata)) (sshPrivKey sshkeypair)
+ writeFileProtected (sshdir </> sshPrivKeyFile sshdata)
+ (sshPrivKey sshkeypair)
unlessM (doesFileExist $ sshdir </> sshPubKeyFile sshdata) $
- writeFile (sshdir </> sshPubKeyFile sshdata) (sshPubKey sshkeypair)
+ writeFile (fromOsPath (sshdir </> sshPubKeyFile sshdata))
+ (sshPubKey sshkeypair)
setSshConfig sshdata
- [ ("IdentityFile", "~/.ssh/" ++ sshPrivKeyFile sshdata)
+ [ ("IdentityFile", "~/.ssh/" ++ fromOsPath (sshPrivKeyFile sshdata))
, ("IdentitiesOnly", "yes")
, ("StrictHostKeyChecking", "yes")
]
-sshPrivKeyFile :: SshData -> FilePath
-sshPrivKeyFile sshdata = "git-annex" </> "key." ++ mangleSshHostName sshdata
+sshPrivKeyFile :: SshData -> OsPath
+sshPrivKeyFile sshdata = literalOsPath "git-annex"
+ </> literalOsPath "key." <> toOsPath (mangleSshHostName sshdata)
-sshPubKeyFile :: SshData -> FilePath
-sshPubKeyFile sshdata = sshPrivKeyFile sshdata ++ ".pub"
+sshPubKeyFile :: SshData -> OsPath
+sshPubKeyFile sshdata = sshPrivKeyFile sshdata <> literalOsPath ".pub"
{- Generates an installs a new ssh key pair if one is not already
- installed. Returns the modified SshData that will use the key pair,
setupSshKeyPair :: SshData -> IO (SshData, SshKeyPair)
setupSshKeyPair sshdata = do
sshdir <- sshDir
- mprivkey <- catchMaybeIO $ readFile (sshdir </> sshPrivKeyFile sshdata)
- mpubkey <- catchMaybeIO $ readFile (sshdir </> sshPubKeyFile sshdata)
+ mprivkey <- catchMaybeIO $ readFile (fromOsPath (sshdir </> sshPrivKeyFile sshdata))
+ mpubkey <- catchMaybeIO $ readFile (fromOsPath (sshdir </> sshPubKeyFile sshdata))
keypair <- case (mprivkey, mpubkey) of
(Just privkey, Just pubkey) -> return $ SshKeyPair
{ sshPubKey = pubkey
setSshConfig sshdata config = do
sshdir <- sshDir
createDirectoryIfMissing True sshdir
- let configfile = sshdir </> "config"
+ let configfile = fromOsPath (sshdir </> literalOsPath "config")
unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $ do
appendFile configfile $ unlines $
[ ""
, "Host " ++ mangledhost
] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v)
(settings ++ config)
- setSshConfigMode (toRawFilePath configfile)
+ setSshConfigMode (toOsPath configfile)
return $ sshdata
{ sshHostName = T.pack mangledhost
knownHost :: Text -> IO Bool
knownHost hostname = do
sshdir <- sshDir
- ifM (doesFileExist $ sshdir </> "known_hosts")
+ ifM (doesFileExist $ sshdir </> literalOsPath "known_hosts")
( not . null <$> checkhost
, return False
)
liftAnnex $ do
-- Clean up anything left behind by a previous process
-- on unclean shutdown.
- void $ liftIO $ tryIO $ removeDirectoryRecursive
- (fromRawFilePath lockdowndir)
+ void $ liftIO $ tryIO $ removeDirectoryRecursive lockdowndir
void $ createAnnexDirectory lockdowndir
waitChangeTime $ \(changes, time) -> do
- readychanges <- handleAdds (fromRawFilePath lockdowndir) havelsof largefilematcher annexdotfiles delayadd $
+ readychanges <- handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd $
simplifyChanges changes
if shouldCommit False time (length readychanges) readychanges
then do
- Any pending adds that are not ready yet are put back into the ChangeChan,
- where they will be retried later.
-}
-handleAdds :: FilePath -> Bool -> GetFileMatcher -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change]
+handleAdds :: OsPath -> Bool -> GetFileMatcher -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change]
handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = returnWhen (null incomplete) $ do
let (pending, inprocess) = partition isPendingAddChange incomplete
let lockdownconfig = LockDownConfig
{ lockingFile = False
- , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir)
+ , hardlinkFileTmpDir = Just lockdowndir
, checkWritePerms = True
}
(postponed, toadd) <- partitionEithers
| otherwise = a
checkpointerfile change = do
- let file = toRawFilePath $ changeFile change
+ let file = changeFile change
mk <- liftIO $ isPointerFile file
case mk of
Nothing -> return (Right change)
Just key -> do
- mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
+ mode <- liftIO $ catchMaybeIO $
+ fileMode <$> R.getFileStatus (fromOsPath file)
liftAnnex $ stagePointerFile file mode =<< hashPointerFile key
return $ Left $ Change
(changeTime change)
else checkmatcher
| otherwise = checkmatcher
where
- f = toRawFilePath (changeFile change)
+ f = changeFile change
checkmatcher = ifM (liftAnnex $ checkFileMatcher NoLiveUpdate largefilematcher f)
( return (Left change)
, return (Right change)
addsmall [] = noop
addsmall toadd = liftAnnex $ void $ tryIO $
- forM (map (toRawFilePath . changeFile) toadd) $ \f ->
+ forM (map changeFile toadd) $ \f ->
Command.Add.addFile Command.Add.Small f
- =<< liftIO (R.getSymbolicLinkStatus f)
+ =<< liftIO (R.getSymbolicLinkStatus (fromOsPath f))
{- Avoid overhead of re-injesting a renamed unlocked file, by
- examining the other Changes to see if a removed file has the
delta <- liftAnnex getTSDelta
let cfg = LockDownConfig
{ lockingFile = False
- , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir)
+ , hardlinkFileTmpDir = Just lockdowndir
, checkWritePerms = True
}
if M.null m
then forM toadd (addannexed' cfg)
else forM toadd $ \c -> do
- mcache <- liftIO $ genInodeCache (toRawFilePath (changeFile c)) delta
+ mcache <- liftIO $ genInodeCache (changeFile c) delta
case mcache of
Nothing -> addannexed' cfg c
Just cache ->
(mkey, _mcache) <- liftAnnex $ do
showStartMessage (StartMessage "add" (ActionItemOther (Just (QuotedPath (keyFilename ks)))) (SeekInput []))
ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing
- maybe (failedingest change) (done change $ fromRawFilePath $ keyFilename ks) mkey
+ maybe (failedingest change) (done change $ keyFilename ks) mkey
addannexed' _ _ = return Nothing
fastadd :: Change -> Key -> Assistant (Maybe Change)
fastadd change key = do
let source = keySource $ lockedDown change
liftAnnex $ finishIngestUnlocked key source
- done change (fromRawFilePath $ keyFilename source) key
+ done change (keyFilename source) key
removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key)
removedKeysMap ct l = do
mks <- forM (filter isRmChange l) $ \c ->
- catKeyFile $ toRawFilePath $ changeFile c
+ catKeyFile $ changeFile c
M.fromList . concat <$> mapM mkpairs (catMaybes mks)
where
mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$>
done change file key = liftAnnex $ do
logStatus NoLiveUpdate key InfoPresent
- mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file)
- stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key
+ mode <- liftIO $ catchMaybeIO $
+ fileMode <$> R.getFileStatus (fromOsPath file)
+ stagePointerFile file mode =<< hashPointerFile key
showEndOk
return $ Just $ finishedChange change key
- and is still a hard link to its contentLocation,
- before ingesting it. -}
sanitycheck keysource a = do
- fs <- liftIO $ R.getSymbolicLinkStatus $ keyFilename keysource
- ks <- liftIO $ R.getSymbolicLinkStatus $ contentLocation keysource
+ fs <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath $ keyFilename keysource
+ ks <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath $ contentLocation keysource
if deviceID ks == deviceID fs && fileID ks == fileID fs
then a
else do
-- remove the hard link
when (contentLocation keysource /= keyFilename keysource) $
- void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation keysource
+ void $ liftIO $ tryIO $ removeFile $ contentLocation keysource
return Nothing
{- Shown an alert while performing an action to add a file or
- the add succeeded.
-}
addaction [] a = a
- addaction toadd a = alertWhile' (addFileAlert $ map changeFile toadd) $
+ addaction toadd a = alertWhile' (addFileAlert $ map (fromOsPath . changeFile) toadd) $
(,)
<$> pure True
<*> a
-
- Check by running lsof on the repository.
-}
-safeToAdd :: FilePath -> LockDownConfig -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change]
+safeToAdd :: OsPath -> LockDownConfig -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change]
safeToAdd _ _ _ _ [] [] = return []
safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do
maybe noop (liftIO . threadDelaySeconds) delayadd
then S.fromList . map fst3 . filter openwrite <$>
findopenfiles (map (keySource . lockedDown) inprocess')
else pure S.empty
- let checked = map (check openfiles) inprocess'
+ let openfiles' = S.map toOsPath openfiles
+ let checked = map (check openfiles') inprocess'
{- If new events are received when files are closed,
- there's no need to retry any changes that cannot
else return checked
where
check openfiles change@(InProcessAddChange { lockedDown = ld })
- | S.member (fromRawFilePath (contentLocation (keySource ld))) openfiles = Left change
+ | S.member (contentLocation (keySource ld)) openfiles = Left change
check _ change = Right change
mkinprocess (c, Just ld) = Just InProcessAddChange
<> " still has writers, not adding"
-- remove the hard link
when (contentLocation ks /= keyFilename ks) $
- void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation ks
+ void $ liftIO $ tryIO $ removeFile $ contentLocation ks
canceladd _ = noop
openwrite (_file, mode, _pid)
findopenfiles keysources = ifM crippledFileSystem
( liftIO $ do
let segments = segmentXargsUnordered $
- map (fromRawFilePath . keyFilename) keysources
+ map (fromOsPath . keyFilename) keysources
concat <$> forM segments (\fs -> Lsof.query $ "--" : fs)
- , liftIO $ Lsof.queryDir lockdowndir
+ , liftIO $ Lsof.queryDir (fromOsPath lockdowndir)
)
{- After a Change is committed, queue any necessary transfers or drops
handleDrops "file renamed" present k af []
where
f = changeFile change
- af = AssociatedFile (Just (toRawFilePath f))
+ af = AssociatedFile (Just f)
checkChangeContent _ = noop
when (old /= new) $ do
let changedconfigs = new `S.difference` old
debug $ "reloading config" :
- map (fromRawFilePath . fst)
+ map (fromOsPath . fst)
(S.toList changedconfigs)
reloadConfigs new
{- Record a commit to get this config
loop new
{- Config files, and their checksums. -}
-type Configs = S.Set (RawFilePath, Sha)
+type Configs = S.Set (OsPath, Sha)
{- All git-annex's config files, and actions to run when they change. -}
-configFilesActions :: [(RawFilePath, Assistant ())]
+configFilesActions :: [(OsPath, Assistant ())]
configFilesActions =
[ (uuidLog, void $ liftAnnex uuidDescMapLoad)
, (remoteLog, void $ liftAnnex remotesChanged)
getConfigs = S.fromList . map extract
<$> liftAnnex (inRepo $ LsTree.lsTreeFiles (LsTree.LsTreeLong False) Annex.Branch.fullname files)
where
- files = map (fromRawFilePath . fst) configFilesActions
+ files = map (fromOsPath . fst) configFilesActions
extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem)
runActivity' :: UrlRenderer -> ScheduledActivity -> Assistant ()
runActivity' urlrenderer (ScheduledSelfFsck _ d) = do
- program <- liftIO programPath
+ program <- fromOsPath <$> liftIO programPath
g <- liftAnnex gitRepo
fsckresults <- showFscking urlrenderer Nothing $ tryNonAsync $ do
void $ batchCommand program (Param "fsck" : annexFsckParams d)
dispatch Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s]
dispatch (Just rmt) = void $ case Remote.remoteFsck rmt of
Nothing -> go rmt $ do
- program <- programPath
+ program <- fromOsPath <$> programPath
void $ batchCommand program $
[ Param "fsck"
-- avoid downloading files
import qualified Git.Branch
import qualified Git.Ref
import qualified Command.Sync
-
-import qualified System.FilePath.ByteString as P
+import qualified Utility.OsString as OS
{- This thread watches for changes to .git/refs/, and handles incoming
- pushes. -}
mergeThread = namedThread "Merger" $ do
g <- liftAnnex gitRepo
let gitd = Git.localGitDir g
- let dir = gitd P.</> "refs"
+ let dir = gitd </> literalOsPath "refs"
liftIO $ createDirectoryUnder [gitd] dir
let hook a = Just <$> asIO2 (runHandler a)
changehook <- hook onChange
, modifyHook = changehook
, errHook = errhook
}
- void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id
- debug ["watching", fromRawFilePath dir]
+ void $ liftIO $ watchDir dir (const False) True hooks id
+ debug ["watching", fromOsPath dir]
-type Handler = FilePath -> Assistant ()
+type Handler t = t -> Assistant ()
{- Runs an action handler.
-
- Exceptions are ignored, otherwise a whole thread could be crashed.
-}
-runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
+runHandler :: Handler t -> t -> Maybe FileStatus -> Assistant ()
runHandler handler file _filestatus =
either (liftIO . print) (const noop) =<< tryIO <~> handler file
{- Called when there's an error with inotify. -}
-onErr :: Handler
+onErr :: Handler String
onErr = giveup
{- Called when a new branch ref is written, or a branch ref is modified.
- ok; it ensures that any changes pushed since the last time the assistant
- ran are merged in.
-}
-onChange :: Handler
+onChange :: Handler OsPath
onChange file
- | ".lock" `isSuffixOf` file = noop
+ | literalOsPath ".lock" `OS.isSuffixOf` file = noop
| isAnnexBranch file = do
branchChanged
diverged <- liftAnnex Annex.Branch.forceUpdate >>= return . \case
- to the second branch, which should be merged into it? -}
isRelatedTo :: Git.Ref -> Git.Ref -> Bool
isRelatedTo x y
- | basex /= takeDirectory basex ++ "/" ++ basey = False
+ | basex /= fromOsPath (takeDirectory (toOsPath basex)) ++ "/" ++ basey = False
| "/synced/" `isInfixOf` Git.fromRef x = True
| "refs/remotes/" `isPrefixOf` Git.fromRef x = True
| otherwise = False
basex = Git.fromRef $ Git.Ref.base x
basey = Git.fromRef $ Git.Ref.base y
-isAnnexBranch :: FilePath -> Bool
-isAnnexBranch f = n `isSuffixOf` f
+isAnnexBranch :: OsPath -> Bool
+isAnnexBranch f = n `isSuffixOf` fromOsPath f
where
n = '/' : Git.fromRef Annex.Branch.name
-fileToBranch :: FilePath -> Git.Ref
-fileToBranch f = Git.Ref $ encodeBS $ "refs" </> base
+fileToBranch :: OsPath -> Git.Ref
+fileToBranch f = Git.Ref $ fromOsPath $ literalOsPath "refs" </> toOsPath base
where
- base = Prelude.last $ split "/refs/" f
+ base = Prelude.last $ split "/refs/" (fromOsPath f)
handleMounts :: UrlRenderer -> MountPoints -> MountPoints -> Assistant ()
handleMounts urlrenderer wasmounted nowmounted =
- mapM_ (handleMount urlrenderer . mnt_dir) $
+ mapM_ (handleMount urlrenderer . toOsPath . mnt_dir) $
S.toList $ newMountPoints wasmounted nowmounted
-handleMount :: UrlRenderer -> FilePath -> Assistant ()
+handleMount :: UrlRenderer -> OsPath -> Assistant ()
handleMount urlrenderer dir = do
- debug ["detected mount of", dir]
+ debug ["detected mount of", fromOsPath dir]
rs <- filterM (Git.repoIsLocal <$$> liftAnnex . Remote.getRepo)
=<< remotesUnder dir
mapM_ (fsckNudge urlrenderer . Just) rs
- at startup time, or may have changed (it could even be a different
- repository at the same remote location..)
-}
-remotesUnder :: FilePath -> Assistant [Remote]
+remotesUnder :: OsPath -> Assistant [Remote]
remotesUnder dir = do
repotop <- liftAnnex $ fromRepo Git.repoPath
rs <- liftAnnex remoteList
return $ mapMaybe snd $ filter fst pairs
where
checkremote repotop r = case Remote.localpath r of
- Just p | dirContains (toRawFilePath dir) (absPathFrom repotop (toRawFilePath p)) ->
+ Just p | dirContains dir (absPathFrom repotop p) ->
(,) <$> pure True <*> updateRemote r
_ -> return (False, Just r)
pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress]
pairAckReceived True (Just pip) msg cache = do
stopSending pip
- repodir <- fromRawFilePath . repoPath <$> liftAnnex gitRepo
+ repodir <- repoPath <$> liftAnnex gitRepo
liftIO $ setupAuthorizedKeys msg repodir
finishedLocalPairing msg (inProgressSshKeyPair pip)
startSending pip PairDone $ multicastPairMsg
remoteControlThread :: NamedThread
remoteControlThread = namedThread "RemoteControl" $ do
- program <- liftIO programPath
+ program <- liftIO $ fromOsPath <$> programPath
(cmd, params) <- liftIO $ toBatchCommand
(program, [Param "remotedaemon", Param "--foreground"])
let p = proc cmd (toCommand params)
ifM (not <$> liftAnnex (inRepo checkIndexFast))
( do
debug ["corrupt index file found at startup; removing and restaging"]
- liftAnnex $ inRepo $ removeWhenExistsWith R.removeLink . indexFile
+ liftAnnex $ inRepo $ removeWhenExistsWith removeFile . indexFile
{- Normally the startup scan avoids re-staging files,
- but with the index deleted, everything needs to be
- restaged. -}
- will be automatically regenerated. -}
unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do
debug ["corrupt annex/index file found at startup; removing"]
- liftAnnex $ liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexIndex
+ liftAnnex $ liftIO . removeWhenExistsWith removeFile =<< fromRepo gitAnnexIndex
{- Fix up ssh remotes set up by past versions of the assistant. -}
liftIO $ fixUpSshRemotes
batchmaker <- liftIO getBatchCommandMaker
-- Find old unstaged symlinks, and add them to git.
- (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo [] False ["."] g
+ (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo [] False [literalOsPath "."] g
now <- liftIO getPOSIXTime
forM_ unstaged $ \file -> do
- ms <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file
+ ms <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath file
case ms of
Just s | toonew (statusChangeTime s) now -> noop
- | isSymbolicLink s -> addsymlink (fromRawFilePath file) ms
+ | isSymbolicLink s -> addsymlink file ms
_ -> noop
liftIO $ void cleanup
{- Run git-annex unused once per day. This is run as a separate
- process to stay out of the annex monad and so it can run as a
- batch job. -}
- program <- liftIO programPath
+ program <- fromOsPath <$> liftIO programPath
let (program', params') = batchmaker (program, [Param "unused"])
void $ liftIO $ boolSystem program' params'
{- Invalidate unused keys cache, and queue transfers of all unused
void $ addAlert $ sanityCheckFixAlert msg
addsymlink file s = do
Watcher.runHandler Watcher.onAddSymlink file s
- insanity $ "found unstaged symlink: " ++ file
+ insanity $ "found unstaged symlink: " ++ fromOsPath file
hourlyCheck :: Assistant ()
hourlyCheck = do
-}
checkLogSize :: Int -> Assistant ()
checkLogSize n = do
- f <- liftAnnex $ fromRawFilePath <$> fromRepo gitAnnexDaemonLogFile
- logs <- liftIO $ listLogs f
- totalsize <- liftIO $ sum <$> mapM (getFileSize . toRawFilePath) logs
+ f <- liftAnnex $ fromRepo gitAnnexDaemonLogFile
+ logs <- liftIO $ listLogs (fromOsPath f)
+ totalsize <- liftIO $ sum <$> mapM (getFileSize . toOsPath) logs
when (totalsize > 2 * oneMegabyte) $ do
debug ["Rotated logs due to size:", show totalsize]
- liftIO $ openLog f >>= handleToFd >>= redirLog
+ liftIO $ openLog (fromOsPath f) >>= handleToFd >>= redirLog
when (n < maxLogs + 1) $ do
- df <- liftIO $ getDiskFree $ takeDirectory f
+ df <- liftIO $ getDiskFree $ fromOsPath $ takeDirectory f
case df of
Just free
| free < fromIntegral totalsize ->
checkRepoExists :: Assistant ()
checkRepoExists = do
g <- liftAnnex gitRepo
- liftIO $ unlessM (doesDirectoryExist $ fromRawFilePath $ Git.repoPath g) $
+ liftIO $ unlessM (doesDirectoryExist $ Git.repoPath g) $
terminateSelf
, modifyHook = modifyhook
, errHook = errhook
}
- void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id
+ void $ liftIO $ watchDir dir (const False) True hooks id
debug ["watching for transfers"]
-type Handler = FilePath -> Assistant ()
+type Handler t = t -> Assistant ()
{- Runs an action handler.
-
- Exceptions are ignored, otherwise a whole thread could be crashed.
-}
-runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
+runHandler :: Handler t -> t -> Maybe FileStatus -> Assistant ()
runHandler handler file _filestatus =
either (liftIO . print) (const noop) =<< tryIO <~> handler file
{- Called when there's an error with inotify. -}
-onErr :: Handler
+onErr :: Handler String
onErr = giveup
{- Called when a new transfer information file is written. -}
-onAdd :: Handler
-onAdd file = case parseTransferFile (toRawFilePath file) of
+onAdd :: Handler OsPath
+onAdd file = case parseTransferFile file of
Nothing -> noop
Just t -> go t =<< liftAnnex (checkTransfer t)
where
-
- The only thing that should change in the transfer info is the
- bytesComplete, so that's the only thing updated in the DaemonStatus. -}
-onModify :: Handler
-onModify file = case parseTransferFile (toRawFilePath file) of
+onModify :: Handler OsPath
+onModify file = case parseTransferFile file of
Nothing -> noop
- Just t -> go t =<< liftIO (readTransferInfoFile Nothing (toRawFilePath file))
+ Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
where
go _ Nothing = noop
go t (Just newinfo) = alterTransferInfo t $
watchesTransferSize = modifyTracked
{- Called when a transfer information file is removed. -}
-onDel :: Handler
-onDel file = case parseTransferFile (toRawFilePath file) of
+onDel :: Handler OsPath
+onDel file = case parseTransferFile file of
Nothing -> noop
Just t -> do
debug [ "transfer finishing:", show t]
, modifyHook = changed
, delDirHook = changed
}
- let dir = fromRawFilePath (parentDir (toRawFilePath flagfile))
+ let dir = parentDir flagfile
let depth = length (splitPath dir) + 1
let nosubdirs f = length (splitPath f) == depth
void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)
void $ swapMVar mvar Started
return r
-changedFile :: UrlRenderer -> MVar WatcherState -> FilePath -> FilePath -> Maybe FileStatus -> Assistant ()
+changedFile :: UrlRenderer -> MVar WatcherState -> OsPath -> OsPath -> Maybe FileStatus -> Assistant ()
changedFile urlrenderer mvar flagfile file _status
| flagfile /= file = noop
| otherwise = do
import Config.GitConfig
import Utility.ThreadScheduler
import Logs.Location
+import qualified Utility.OsString as OS
import qualified Database.Keys
#ifndef mingw32_HOST_OS
import qualified Utility.Lsof as Lsof
delhook <- hook onDel
addsymlinkhook <- hook onAddSymlink
deldirhook <- hook onDelDir
- errhook <- hook onErr
+ errhook <- asIO2 onErr
let hooks = mkWatchHooks
{ addHook = addhook
, delHook = delhook
, addSymlinkHook = addsymlinkhook
, delDirHook = deldirhook
- , errHook = errhook
+ , errHook = Just errhook
}
scanevents <- liftAnnex $ annexStartupScan <$> Annex.getGitConfig
- h <- liftIO $ watchDir "." ignored scanevents hooks startup
+ h <- liftIO $ watchDir (literalOsPath ".") ignored scanevents hooks startup
debug [ "watching", "."]
{- Let the DirWatcher thread run until signalled to pause it,
top <- liftAnnex $ fromRepo Git.repoPath
(fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [] [top]
forM_ fs $ \f -> do
- let f' = fromRawFilePath f
- liftAnnex $ onDel' f'
- maybe noop recordChange =<< madeChange f' RmChange
+ liftAnnex $ onDel' f
+ maybe noop recordChange =<< madeChange f RmChange
void $ liftIO cleanup
liftAnnex $ showAction "started"
{- Hardcoded ignores, passed to the DirWatcher so it can avoid looking
- at the entire .git directory. Does not include .gitignores. -}
-ignored :: FilePath -> Bool
+ignored :: OsPath -> Bool
ignored = ig . takeFileName
where
- ig ".git" = True
- ig ".gitignore" = True
- ig ".gitattributes" = True
+ ig f
+ | f == literalOsPath ".git" = True
+ | f == literalOsPath ".gitignore" = True
+ | f == literalOsPath ".gitattributes" = True
#ifdef darwin_HOST_OS
- ig ".DS_Store" = True
+ | f == literlosPath ".DS_Store" = True
#endif
- ig _ = False
+ | otherwise = False
-unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change)
-unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) (toRawFilePath file))
+unlessIgnored :: OsPath -> Assistant (Maybe Change) -> Assistant (Maybe Change)
+unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) file)
( noChange
, a
)
-type Handler = FilePath -> Maybe FileStatus -> Assistant (Maybe Change)
+type Handler = OsPath -> Maybe FileStatus -> Assistant (Maybe Change)
{- Runs an action handler, and if there was a change, adds it to the ChangeChan.
-
- Exceptions are ignored, otherwise a whole watcher thread could be crashed.
-}
-runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
+runHandler :: Handler -> OsPath -> Maybe FileStatus -> Assistant ()
runHandler handler file filestatus = void $ do
r <- tryIO <~> handler (normalize file) filestatus
case r of
Right (Just change) -> recordChange change
where
normalize f
- | "./" `isPrefixOf` file = drop 2 f
+ | literalOsPath "./" `OS.isPrefixOf` file = OS.drop 2 f
| otherwise = f
shouldRestage :: DaemonStatus -> Bool
where
addassociatedfile key file =
Database.Keys.addAssociatedFile key
- =<< inRepo (toTopFilePath (toRawFilePath file))
+ =<< inRepo (toTopFilePath file)
samefilestatus key file status = do
cache <- Database.Keys.getInodeCaches key
curr <- withTSDelta $ \delta ->
- liftIO $ toInodeCache delta (toRawFilePath file) status
+ liftIO $ toInodeCache delta file status
case (cache, curr) of
(_, Just c) -> elemInodeCaches c cache
([], Nothing) -> return True
_ -> return False
contentchanged oldkey file = do
Database.Keys.removeAssociatedFile oldkey
- =<< inRepo (toTopFilePath (toRawFilePath file))
+ =<< inRepo (toTopFilePath file)
unlessM (inAnnex oldkey) $
logStatus NoLiveUpdate oldkey InfoMissing
addlink file key = do
- mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file)
- liftAnnex $ stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key
+ mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath file)
+ liftAnnex $ stagePointerFile file mode =<< hashPointerFile key
madeChange file $ LinkChange (Just key)
onAddFile'
- :: (Key -> FilePath -> Annex ())
- -> (Key -> FilePath -> Annex ())
- -> (FilePath -> Key -> Assistant (Maybe Change))
- -> (Key -> FilePath -> FileStatus -> Annex Bool)
+ :: (Key -> OsPath -> Annex ())
+ -> (Key -> OsPath -> Annex ())
+ -> (OsPath -> Key -> Assistant (Maybe Change))
+ -> (Key -> OsPath -> FileStatus -> Annex Bool)
-> Bool
-> Handler
onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssupported file fs = do
- v <- liftAnnex $ catKeyFile (toRawFilePath file)
+ v <- liftAnnex $ catKeyFile file
case (v, fs) of
(Just key, Just filestatus) ->
ifM (liftAnnex $ samefilestatus key file filestatus)
, noChange
)
, guardSymlinkStandin (Just key) $ do
- debug ["changed", file]
+ debug ["changed", fromOsPath file]
liftAnnex $ contentchanged key file
pendingAddChange file
)
_ -> unlessIgnored file $
guardSymlinkStandin Nothing $ do
- debug ["add", file]
+ debug ["add", fromOsPath file]
pendingAddChange file
where
{- On a filesystem without symlinks, we'll get changes for regular
guardSymlinkStandin mk a
| symlinkssupported = a
| otherwise = do
- linktarget <- liftAnnex $ getAnnexLinkTarget $
- toRawFilePath file
+ linktarget <- liftAnnex $ getAnnexLinkTarget file
case linktarget of
Nothing -> a
Just lt -> do
-}
onAddSymlink :: Handler
onAddSymlink file filestatus = unlessIgnored file $ do
- linktarget <- liftIO (catchMaybeIO $ R.readSymbolicLink file')
- kv <- liftAnnex (lookupKey file')
+ linktarget <- liftIO $ catchMaybeIO $
+ R.readSymbolicLink (fromOsPath file)
+ kv <- liftAnnex (lookupKey file)
onAddSymlink' linktarget kv file filestatus
- where
- file' = toRawFilePath file
onAddSymlink' :: Maybe LinkTarget -> Maybe Key -> Handler
onAddSymlink' linktarget mk file filestatus = go mk
where
go (Just key) = do
- link <- liftAnnex $ calcRepo $ gitAnnexLink (toRawFilePath file) key
+ link <- liftAnnex $ fromOsPath <$> calcRepo (gitAnnexLink file key)
if linktarget == Just link
then ensurestaged (Just link) =<< getDaemonStatus
else do
- liftAnnex $ replaceWorkTreeFile (toRawFilePath file) $
+ liftAnnex $ replaceWorkTreeFile file $
makeAnnexLink link
addLink file link (Just key)
-- other symlink, not git-annex
ensurestaged Nothing _ = noChange
{- For speed, tries to reuse the existing blob for symlink target. -}
-addLink :: FilePath -> LinkTarget -> Maybe Key -> Assistant (Maybe Change)
+addLink :: OsPath -> LinkTarget -> Maybe Key -> Assistant (Maybe Change)
addLink file link mk = do
- debug ["add symlink", file]
+ debug ["add symlink", fromOsPath file]
liftAnnex $ do
- v <- catObjectDetails $ Ref $ encodeBS $ ':':file
+ v <- catObjectDetails $ Ref $ encodeBS $ ':':fromOsPath file
case v of
Just (currlink, sha, _type)
| L.fromStrict link == currlink ->
- stageSymlink (toRawFilePath file) sha
- _ -> stageSymlink (toRawFilePath file)
- =<< hashSymlink link
+ stageSymlink file sha
+ _ -> stageSymlink file =<< hashSymlink link
madeChange file $ LinkChange mk
onDel :: Handler
onDel file _ = do
- debug ["file deleted", file]
+ debug ["file deleted", fromOsPath file]
liftAnnex $ onDel' file
madeChange file RmChange
-onDel' :: FilePath -> Annex ()
+onDel' :: OsPath -> Annex ()
onDel' file = do
- topfile <- inRepo (toTopFilePath (toRawFilePath file))
+ topfile <- inRepo (toTopFilePath file)
withkey $ flip Database.Keys.removeAssociatedFile topfile
Annex.Queue.addUpdateIndex =<<
- inRepo (Git.UpdateIndex.unstageFile (toRawFilePath file))
+ inRepo (Git.UpdateIndex.unstageFile file)
where
- withkey a = maybe noop a =<< catKeyFile (toRawFilePath file)
+ withkey a = maybe noop a =<< catKeyFile file
{- A directory has been deleted, or moved, so tell git to remove anything
- that was inside it from its cache. Since it could reappear at any time,
- pairing up renamed files when the directory was renamed. -}
onDelDir :: Handler
onDelDir dir _ = do
- debug ["directory deleted", dir]
- (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [] [toRawFilePath dir]
- let fs' = map fromRawFilePath fs
+ debug ["directory deleted", fromOsPath dir]
+ (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [] [dir]
- liftAnnex $ mapM_ onDel' fs'
+ liftAnnex $ mapM_ onDel' fs
-- Get the events queued up as fast as possible, so the
-- committer sees them all in one block.
now <- liftIO getCurrentTime
- recordChanges $ map (\f -> Change now f RmChange) fs'
+ recordChanges $ map (\f -> Change now f RmChange) fs
void $ liftIO clean
noChange
{- Called when there's an error with inotify or kqueue. -}
-onErr :: Handler
+onErr :: String -> Maybe FileStatus -> Assistant ()
onErr msg _ = do
liftAnnex $ warning (UnquotedString msg)
void $ addAlert $ warningAlert "watcher" msg
- noChange
-> Maybe (IO Url)
-> Maybe HostName
-> Maybe PortNumber
- -> Maybe (Url -> FilePath -> IO ())
+ -> Maybe (Url -> OsPath -> IO ())
-> NamedThread
webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost listenport onstartup = thread $ liftIO $ do
listenhost' <- if isJust listenhost
, return app
)
runWebApp tlssettings listenhost' listenport' app' $ \addr -> if noannex
- then withTmpFile (toOsPath "webapp.html") $ \tmpfile h -> do
+ then withTmpFile (literalOsPath "webapp.html") $ \tmpfile h -> do
hClose h
- go tlssettings addr webapp (fromRawFilePath (fromOsPath tmpfile)) Nothing
+ go tlssettings addr webapp tmpfile Nothing
else do
htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim
urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile
- go tlssettings addr webapp
- (fromRawFilePath htmlshim)
- (Just urlfile)
+ go tlssettings addr webapp htmlshim (Just urlfile)
where
-- The webapp thread does not wait for the startupSanityCheckThread
-- to finish, so that the user interface remains responsive while
thread = namedThreadUnchecked "WebApp"
getreldir
| noannex = return Nothing
- | otherwise = Just <$>
- (relHome . fromRawFilePath =<< absPath =<< getAnnex' (fromRepo repoPath))
+ | otherwise = Just . fromOsPath <$>
+ (relHome =<< absPath =<< getAnnex' (fromRepo repoPath))
go tlssettings addr webapp htmlshim urlfile = do
let url = myUrl tlssettings webapp addr
maybe noop (`writeFileProtected` url) urlfile
cert <- fromRepo gitAnnexWebCertificate
privkey <- fromRepo gitAnnexWebPrivKey
ifM (liftIO $ allM doesFileExist [cert, privkey])
- ( return $ Just $ TLS.tlsSettings cert privkey
+ ( return $ Just $ TLS.tlsSettings
+ (fromOsPath cert)
+ (fromOsPath privkey)
, return Nothing
)
AssociatedFile Nothing -> noop
AssociatedFile (Just af) -> void $
addAlert $ makeAlertFiller True $
- transferFileAlert direction True (fromRawFilePath af)
+ transferFileAlert direction True (fromOsPath af)
unless isdownload $
handleDrops
("object uploaded to " ++ show remote)
module Assistant.Types.Changes where
+import Common
import Types.KeySource
import Types.Key
import Utility.TList
-import Utility.FileSystemEncoding
import Annex.Ingest
import Control.Concurrent.STM
data Change
= Change
{ changeTime :: UTCTime
- , _changeFile :: FilePath
+ , _changeFile :: OsPath
, changeInfo :: ChangeInfo
}
| PendingAddChange
{ changeTime ::UTCTime
- , _changeFile :: FilePath
+ , _changeFile :: OsPath
}
| InProcessAddChange
{ changeTime ::UTCTime
changeInfoKey (LinkChange (Just k)) = Just k
changeInfoKey _ = Nothing
-changeFile :: Change -> FilePath
+changeFile :: Change -> OsPath
changeFile (Change _ f _) = f
changeFile (PendingAddChange _ f) = f
-changeFile (InProcessAddChange _ ld) = fromRawFilePath $ keyFilename $ keySource ld
+changeFile (InProcessAddChange _ ld) = keyFilename $ keySource ld
isPendingAddChange :: Change -> Bool
isPendingAddChange (PendingAddChange {}) = True
- than the remaining free disk space, or more than 1/10th the total
- disk space being unused keys all suggest a problem. -}
describeUnused' :: Bool -> Assistant (Maybe TenseText)
-describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog ""
+describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog (literalOsPath "")
where
go m = do
let num = M.size m
sumkeysize s k = s + fromMaybe 0 (fromKey keySize k)
- forpath a = inRepo $ liftIO . a . fromRawFilePath . Git.repoPath
+ forpath a = inRepo $ liftIO . a . fromOsPath . Git.repoPath
{- With a duration, expires all unused files that are older.
- With Nothing, expires *all* unused files. -}
expireUnused :: Maybe Duration -> Assistant ()
expireUnused duration = do
- m <- liftAnnex $ readUnusedLog ""
+ m <- liftAnnex $ readUnusedLog (literalOsPath "")
now <- liftIO getPOSIXTime
let oldkeys = M.keys $ M.filter (tooold now) m
forM_ oldkeys $ \k -> do
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Assistant.Upgrade where
import Utility.Tuple
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
+import qualified Utility.OsString as OS
import Data.Either
import qualified Data.Map as M
-import qualified System.FilePath.ByteString as P
{- Upgrade without interaction in the webapp. -}
unattendedUpgrade :: Assistant ()
hook <- asIO1 $ distributionDownloadComplete d dest cleanup
modifyDaemonStatus_ $ \s -> s
{ transferHook = M.insert k hook (transferHook s) }
- maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just (toRawFilePath f))) t)
+ maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just f)) t)
=<< liftAnnex (remoteFromUUID webUUID)
startTransfer t
k = mkKey $ const $ distributionKey d
u = distributionUrl d
- f = takeFileName u ++ " (for upgrade)"
+ f = takeFileName (toOsPath u) <> literalOsPath " (for upgrade)"
t = Transfer
{ transferDirection = Download
, transferUUID = webUUID
-
- Verifies the content of the downloaded key.
-}
-distributionDownloadComplete :: GitAnnexDistribution -> FilePath -> Assistant () -> Transfer -> Assistant ()
+distributionDownloadComplete :: GitAnnexDistribution -> OsPath -> Assistant () -> Transfer -> Assistant ()
distributionDownloadComplete d dest cleanup t
| transferDirection t == Download = do
debug ["finished downloading git-annex distribution"]
where
k = mkKey $ const $ distributionKey d
fsckit f = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
- Nothing -> return $ Just (fromRawFilePath f)
+ Nothing -> return $ Just f
Just b -> case Types.Backend.verifyKeyContent b of
- Nothing -> return $ Just (fromRawFilePath f)
+ Nothing -> return $ Just f
Just verifier -> ifM (verifier k f)
- ( return $ Just (fromRawFilePath f)
+ ( return $ Just f
, return Nothing
)
go f = do
- and unpack the new distribution next to it (in a versioned directory).
- Then update the programFile to point to the new version.
-}
-upgradeToDistribution :: FilePath -> Assistant () -> FilePath -> Assistant ()
+upgradeToDistribution :: OsPath -> Assistant () -> OsPath -> Assistant ()
upgradeToDistribution newdir cleanup distributionfile = do
liftIO $ createDirectoryIfMissing True newdir
(program, deleteold) <- unpack
postUpgrade url
where
changeprogram program = liftIO $ do
- unlessM (boolSystem program [Param "version"]) $
+ unlessM (boolSystem (fromOsPath program) [Param "version"]) $
giveup "New git-annex program failed to run! Not using."
pf <- programFile
- liftIO $ writeFile pf program
+ liftIO $ writeFile (fromOsPath pf) (fromOsPath program)
#ifdef darwin_HOST_OS
{- OS X uses a dmg, so mount it, and copy the contents into place. -}
unpack = liftIO $ do
olddir <- oldVersionLocation
- withTmpDirIn (fromRawFilePath (parentDir (toRawFilePath newdir))) "git-annex.upgrade" $ \tmpdir -> do
+ withTmpDirIn (parentDir newdir) (literalOsPath "git-annex.upgrade") $ \tmpdir -> do
void $ boolSystem "hdiutil"
[ Param "attach", File distributionfile
- , Param "-mountpoint", File tmpdir
+ , Param "-mountpoint", File (fromOsPath tmpdir)
]
void $ boolSystem "cp"
[ Param "-R"
- , File $ tmpdir </> installBase </> "Contents"
+ , File $ fromOsPath $ tmpdir </> toOsPath installBase </> literalOsPath "Contents"
, File $ newdir
]
void $ boolSystem "hdiutil"
[ Param "eject"
- , File tmpdir
+ , File (fromOsPath tmpdir)
]
sanitycheck newdir
let deleteold = do
- deleteFromManifest $ olddir </> "Contents" </> "MacOS"
+ deleteFromManifest $ toOsPath olddir </> literalOsPath "Contents" </> literalOsPath "MacOS"
makeorigsymlink olddir
- return (newdir </> "Contents" </> "MacOS" </> "git-annex", deleteold)
+ return (newdir </> literalOsPath "Contents" </> literalOsPath "MacOS" </> literalOsPath "git-annex", deleteold)
#else
{- Linux uses a tarball (so could other POSIX systems), so
- untar it (into a temp directory) and move the directory
- into place. -}
unpack = liftIO $ do
olddir <- oldVersionLocation
- withTmpDirIn (fromRawFilePath $ parentDir $ toRawFilePath newdir) (toOsPath $ toRawFilePath "git-annex.upgrade") $ \tmpdir -> do
- let tarball = tmpdir </> "tar"
+ withTmpDirIn (parentDir newdir) (literalOsPath "git-annex.upgrade") $ \tmpdir -> do
+ let tarball = tmpdir </> literalOsPath "tar"
-- Cannot rely on filename extension, and this also
-- avoids problems if tar doesn't support transparent
-- decompression.
void $ boolSystem "sh"
[ Param "-c"
- , Param $ "zcat < " ++ shellEscape distributionfile ++
- " > " ++ shellEscape tarball
+ , Param $ "zcat < " ++ shellEscape (fromOsPath distributionfile) ++
+ " > " ++ shellEscape (fromOsPath tarball)
]
tarok <- boolSystem "tar"
[ Param "xf"
- , Param tarball
- , Param "--directory", File tmpdir
+ , Param (fromOsPath tarball)
+ , Param "--directory", File (fromOsPath tmpdir)
]
unless tarok $
- giveup $ "failed to untar " ++ distributionfile
- sanitycheck $ tmpdir </> installBase
- installby R.rename newdir (tmpdir </> installBase)
+ giveup $ "failed to untar " ++ fromOsPath distributionfile
+ sanitycheck $ tmpdir </> toOsPath installBase
+ installby R.rename newdir (tmpdir </> toOsPath installBase)
let deleteold = do
deleteFromManifest olddir
makeorigsymlink olddir
- return (newdir </> "git-annex", deleteold)
+ return (newdir </> literalOsPath "git-annex", deleteold)
installby a dstdir srcdir =
- mapM_ (\x -> a x (toRawFilePath dstdir P.</> P.takeFileName x))
- =<< dirContents (toRawFilePath srcdir)
+ mapM_ (\x -> a (fromOsPath x) (fromOsPath (dstdir </> takeFileName x)))
+ =<< dirContents srcdir
#endif
sanitycheck dir =
unlessM (doesDirectoryExist dir) $
- giveup $ "did not find " ++ dir ++ " in " ++ distributionfile
+ giveup $ "did not find " ++ fromOsPath dir ++ " in " ++ fromOsPath distributionfile
makeorigsymlink olddir = do
- let origdir = fromRawFilePath (parentDir (toRawFilePath olddir)) </> installBase
- removeWhenExistsWith R.removeLink (toRawFilePath origdir)
- R.createSymbolicLink (toRawFilePath newdir) (toRawFilePath origdir)
+ let origdir = parentDir olddir </> toOsPath installBase
+ removeWhenExistsWith removeFile origdir
+ R.createSymbolicLink (fromOsPath newdir) (fromOsPath origdir)
{- Finds where the old version was installed. -}
-oldVersionLocation :: IO FilePath
+oldVersionLocation :: IO OsPath
oldVersionLocation = readProgramFile >>= \case
Nothing -> giveup "Cannot find old distribution bundle; not upgrading."
Just pf -> do
- let pdir = fromRawFilePath $ parentDir $ toRawFilePath pf
+ let pdir = parentDir pf
#ifdef darwin_HOST_OS
let dirs = splitDirectories pdir
{- It will probably be deep inside a git-annex.app directory. -}
- let olddir = case findIndex ("git-annex.app" `isPrefixOf`) dirs of
+ let olddir = case findIndex (literalOsPath "git-annex.app" `OS.isPrefixOf`) dirs of
Nothing -> pdir
Just i -> joinPath (take (i + 1) dirs)
#else
let olddir = pdir
#endif
- when (null olddir) $
- giveup $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")"
+ when (OS.null olddir) $
+ giveup $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ fromOsPath pdir ++ ")"
return olddir
{- Finds a place to install the new version.
-
- The directory is created. If it already exists, returns Nothing.
-}
-newVersionLocation :: GitAnnexDistribution -> FilePath -> IO (Maybe FilePath)
+newVersionLocation :: GitAnnexDistribution -> OsPath -> IO (Maybe OsPath)
newVersionLocation d olddir =
trymkdir newloc $ do
home <- myHomeDir
- trymkdir (home </> s) $
+ trymkdir (toOsPath home </> s) $
return Nothing
where
- s = installBase ++ "." ++ distributionVersion d
- topdir = fromRawFilePath $ parentDir $ toRawFilePath olddir
+ s = toOsPath $ installBase ++ "." ++ distributionVersion d
+ topdir = parentDir olddir
newloc = topdir </> s
trymkdir dir fallback =
(createDirectory dir >> return (Just dir))
#endif
#endif
-deleteFromManifest :: FilePath -> IO ()
+deleteFromManifest :: OsPath -> IO ()
deleteFromManifest dir = do
- fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest)
- mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath) fs
- removeWhenExistsWith R.removeLink (toRawFilePath manifest)
- removeEmptyRecursive (toRawFilePath dir)
+ fs <- map (\f -> dir </> toOsPath f) . lines
+ <$> catchDefaultIO "" (readFile (fromOsPath manifest))
+ mapM_ (removeWhenExistsWith removeFile) fs
+ removeWhenExistsWith removeFile manifest
+ removeEmptyRecursive dir
where
- manifest = dir </> "git-annex.MANIFEST"
+ manifest = dir </> literalOsPath "git-annex.MANIFEST"
-removeEmptyRecursive :: RawFilePath -> IO ()
+removeEmptyRecursive :: OsPath -> IO ()
removeEmptyRecursive dir = do
mapM_ removeEmptyRecursive =<< dirContents dir
- void $ tryIO $ removeDirectory (fromRawFilePath dir)
+ void $ tryIO $ removeDirectory dir
{- This is a file that the UpgradeWatcher can watch for modifications to
- detect when git-annex has been upgraded.
-}
-upgradeFlagFile :: IO FilePath
+upgradeFlagFile :: IO OsPath
upgradeFlagFile = programPath
{- Sanity check to see if an upgrade is complete and the program is ready
program <- programPath
untilM (doesFileExist program <&&> nowriter program) $
threadDelaySeconds (Seconds 60)
- boolSystem program [Param "version"]
+ boolSystem (fromOsPath program) [Param "version"]
)
where
nowriter f = null
. filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly])
. map snd3
- <$> Lsof.query [f]
+ <$> Lsof.query [fromOsPath f]
usingDistribution :: IO Bool
usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV"
downloadDistributionInfo = do
uo <- liftAnnex Url.getUrlOptions
gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
- liftIO $ withTmpDir (toOsPath (toRawFilePath "git-annex.tmp")) $ \tmpdir -> do
- let infof = tmpdir </> "info"
- let sigf = infof ++ ".sig"
+ liftIO $ withTmpDir (literalOsPath "git-annex.tmp") $ \tmpdir -> do
+ let infof = tmpdir </> literalOsPath "info"
+ let sigf = infof <> literalOsPath ".sig"
ifM (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoUrl infof uo
<&&> (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoSigUrl sigf uo)
<&&> verifyDistributionSig gpgcmd sigf)
( parseInfoFile . map decodeBS . fileLines'
- <$> F.readFile' (toOsPath (toRawFilePath infof))
+ <$> F.readFile' infof
, return Nothing
)
- The gpg keyring used to verify the signature is located in
- trustedkeys.gpg, next to the git-annex program.
-}
-verifyDistributionSig :: GpgCmd -> FilePath -> IO Bool
+verifyDistributionSig :: GpgCmd -> OsPath -> IO Bool
verifyDistributionSig gpgcmd sig = readProgramFile >>= \case
Just p | isAbsolute p ->
- withUmask 0o0077 $ withTmpDir (toOsPath (toRawFilePath "git-annex-gpg.tmp")) $ \gpgtmp -> do
- let trustedkeys = takeDirectory p </> "trustedkeys.gpg"
+ withUmask 0o0077 $ withTmpDir (literalOsPath "git-annex-gpg.tmp") $ \gpgtmp -> do
+ let trustedkeys = takeDirectory p </> literalOsPath "trustedkeys.gpg"
boolGpgCmd gpgcmd
[ Param "--no-default-keyring"
, Param "--no-auto-check-trustdb"
, Param "--no-options"
, Param "--homedir"
- , File gpgtmp
+ , File (fromOsPath gpgtmp)
, Param "--keyring"
- , File trustedkeys
+ , File (fromOsPath trustedkeys)
, Param "--verify"
- , File sig
+ , File (fromOsPath sig)
]
_ -> return False
sanityVerifierAForm $ SanityVerifier magicphrase
case result of
FormSuccess _ -> liftH $ do
- dir <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath
+ dir <- liftAnnex $ fromRepo Git.repoPath
liftIO $ removeAutoStartFile dir
{- Disable syncing to this repository, and all
rs <- syncRemotes <$> getDaemonStatus
mapM_ (\r -> changeSyncable (Just r) False) rs
- liftAnnex $ prepareRemoveAnnexDir (toRawFilePath dir)
- liftIO $ removeDirectoryRecursive . fromRawFilePath
- =<< absPath (toRawFilePath dir)
+ liftAnnex $ prepareRemoveAnnexDir dir
+ liftIO $ removeDirectoryRecursive =<< absPath dir
redirect ShutdownConfirmedR
_ -> $(widgetFile "configurators/delete/currentrepository")
Just t
| T.null t -> noop
| otherwise -> liftAnnex $ do
- let dir = takeBaseName $ T.unpack t
+ let dir = fromOsPath $ takeBaseName $ toOsPath $ T.unpack t
m <- remoteConfigMap
case M.lookup uuid m of
Nothing -> noop
case repoGroup cfg of
RepoGroupStandard gr -> case associatedDirectory repoconfig gr of
Just d -> do
- top <- fromRawFilePath <$> fromRepo Git.repoPath
- createWorkTreeDirectory (toRawFilePath (top </> d))
+ top <- fromRepo Git.repoPath
+ createWorkTreeDirectory (top </> toOsPath d)
Nothing -> noop
_ -> noop
checkRepositoryPath p = do
home <- myHomeDir
let basepath = expandTilde home $ T.unpack p
- path <- fromRawFilePath <$> absPath (toRawFilePath basepath)
- let parent = fromRawFilePath $ parentDir (toRawFilePath path)
+ path <- absPath basepath
+ let parent = parentDir path
problems <- catMaybes <$> mapM runcheck
- [ (return $ path == "/", "Enter the full path to use for the repository.")
- , (return $ all isSpace basepath, "A blank path? Seems unlikely.")
+ [ (return $ path == literalOsPath "/", "Enter the full path to use for the repository.")
+ , (return $ all isSpace (fromOsPath basepath :: FilePath), "A blank path? Seems unlikely.")
, (doesFileExist path, "A file already exists with that name.")
- , (return $ path == home, "Sorry, using git-annex for your whole home directory is not currently supported.")
+ , (return $ fromOsPath path == home, "Sorry, using git-annex for your whole home directory is not currently supported.")
, (not <$> doesDirectoryExist parent, "Parent directory does not exist.")
, (not <$> canWrite path, "Cannot write a repository there.")
]
return $
case headMaybe problems of
- Nothing -> Right $ Just $ T.pack basepath
+ Nothing -> Right $ Just $ T.pack $ fromOsPath basepath
Just prob -> Left prob
where
runcheck (chk, msg) = ifM chk ( return $ Just msg, return Nothing )
- expandTilde home ('~':'/':path) = home </> path
- expandTilde _ path = path
+ expandTilde home ('~':'/':path) = toOsPath home </> toOsPath path
+ expandTilde _ path = toOsPath path
{- On first run, if run in the home directory, default to putting it in
- ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise.
- the user probably wants to put it there. Unless that directory
- contains a git-annex file, in which case the user has probably
- browsed to a directory with git-annex and run it from there. -}
-defaultRepositoryPath :: Bool -> IO FilePath
+defaultRepositoryPath :: Bool -> IO OsPath
defaultRepositoryPath firstrun = do
#ifndef mingw32_HOST_OS
home <- myHomeDir
currdir <- liftIO getCurrentDirectory
- if home == currdir && firstrun
+ if toOsPath home == currdir && firstrun
then inhome
else ifM (legit currdir <&&> canWrite currdir)
( return currdir
where
inhome = ifM osAndroid
( do
- home <- myHomeDir
- let storageshared = home </> "storage" </> "shared"
+ home <- toOsPath <$> myHomeDir
+ let storageshared = home </> literalOsPath "storage" </> literalOsPath "shared"
ifM (doesDirectoryExist storageshared)
( relHome $ storageshared </> gitAnnexAssistantDefaultDir
- , return $ "~" </> gitAnnexAssistantDefaultDir
+ , return $ literalOsPath "~" </> gitAnnexAssistantDefaultDir
)
, do
- desktop <- userDesktopDir
+ desktop <- toOsPath <$> userDesktopDir
ifM (doesDirectoryExist desktop <&&> canWrite desktop)
( relHome $ desktop </> gitAnnexAssistantDefaultDir
- , return $ "~" </> gitAnnexAssistantDefaultDir
+ , return $ literalOsPath "~" </> gitAnnexAssistantDefaultDir
)
)
#ifndef mingw32_HOST_OS
-- Avoid using eg, standalone build's git-annex.linux/ directory
-- when run from there.
- legit d = not <$> doesFileExist (d </> "git-annex")
+ legit d = not <$> doesFileExist (d </> literalOsPath "git-annex")
#endif
-newRepositoryForm :: FilePath -> Hamlet.Html -> MkMForm RepositoryPath
+newRepositoryForm :: OsPath -> Hamlet.Html -> MkMForm RepositoryPath
newRepositoryForm defpath msg = do
(pathRes, pathView) <- mreq (repositoryPathField True) (bfs "")
- (Just $ T.pack $ addTrailingPathSeparator defpath)
+ (Just $ T.pack $ fromOsPath $ addTrailingPathSeparator defpath)
let (err, errmsg) = case pathRes of
FormMissing -> (False, "")
FormFailure l -> (True, concatMap T.unpack l)
((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm path
case res of
FormSuccess (RepositoryPath p) -> liftH $
- startFullAssistant (T.unpack p) ClientGroup Nothing
+ startFullAssistant (toOsPath $ T.unpack p) ClientGroup Nothing
_ -> $(widgetFile "configurators/newrepository/first")
getAndroidCameraRepositoryR :: Handler ()
getAndroidCameraRepositoryR = do
home <- liftIO myHomeDir
- let dcim = home </> "storage" </> "dcim"
+ let dcim = toOsPath home </> literalOsPath "storage" </> literalOsPath "dcim"
startFullAssistant dcim SourceGroup $ Just addignore
where
addignore = do
- liftIO $ unlessM (doesFileExist ".gitignore") $
+ liftIO $ unlessM (doesFileExist $ literalOsPath ".gitignore") $
writeFile ".gitignore" ".thumbnails"
void $ inRepo $
Git.Command.runBool [Param "add", File ".gitignore"]
getNewRepositoryR = postNewRepositoryR
postNewRepositoryR :: Handler Html
postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
- home <- liftIO myHomeDir
+ home <- toOsPath <$> liftIO myHomeDir
((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm home
case res of
FormSuccess (RepositoryPath p) -> do
- let path = T.unpack p
+ let path = toOsPath (T.unpack p)
isnew <- liftIO $ makeRepo path False
u <- liftIO $ initRepo isnew True path Nothing (Just ClientGroup)
liftIO $ addAutoStartFile path
liftIO $ startAssistant path
- askcombine u path
+ askcombine u (fromOsPath path)
_ -> $(widgetFile "configurators/newrepository")
where
askcombine newrepouuid newrepopath = do
- newrepo <- liftIO $ relHome newrepopath
+ newrepo' <- liftIO $ relHome (toOsPath newrepopath)
+ let newrepo = fromOsPath newrepo' :: FilePath
mainrepo <- fromJust . relDir <$> liftH getYesod
$(widgetFile "configurators/newrepository/combine")
getCombineRepositoryR :: FilePath -> UUID -> Handler Html
getCombineRepositoryR newrepopath newrepouuid = do
- liftAssistant . immediateSyncRemote =<< combineRepos newrepopath remotename
+ liftAssistant . immediateSyncRemote
+ =<< combineRepos (toOsPath newrepopath) remotename
redirect $ EditRepositoryR $ RepoUUID newrepouuid
where
- remotename = takeFileName newrepopath
+ remotename = fromOsPath $ takeFileName $ toOsPath newrepopath
selectDriveForm :: [RemovableDrive] -> Hamlet.Html -> MkMForm RemovableDrive
selectDriveForm drives = renderBootstrap3 bootstrapFormLayout $ RemovableDrive
<$> pure Nothing
<*> areq (selectFieldList pairs `withNote` onlywritable) (bfs "Select drive:") Nothing
<*> areq textField (bfs "Use this directory on the drive:")
- (Just $ T.pack gitAnnexAssistantDefaultDir)
+ (Just $ T.pack $ fromOsPath gitAnnexAssistantDefaultDir)
where
pairs = zip (map describe drives) (map mountPoint drives)
describe drive = case diskFree drive of
]
onlywritable = [whamlet|This list only includes drives you can write to.|]
-removableDriveRepository :: RemovableDrive -> FilePath
+removableDriveRepository :: RemovableDrive -> OsPath
removableDriveRepository drive =
- T.unpack (mountPoint drive) </> T.unpack (driveRepoPath drive)
+ toOsPath (T.unpack (mountPoint drive)) </> toOsPath (T.unpack (driveRepoPath drive))
{- Adding a removable drive. -}
getAddDriveR :: Handler Html
postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
removabledrives <- liftIO driveList
writabledrives <- liftIO $
- filterM (canWrite . T.unpack . mountPoint) removabledrives
+ filterM (canWrite . toOsPath . T.unpack . mountPoint) removabledrives
((res, form), enctype) <- liftH $ runFormPostNoToken $
selectDriveForm (sort writabledrives)
case res of
mu <- liftIO $ probeUUID dir
case mu of
Nothing -> maybe askcombine isknownuuid
- =<< liftAnnex (probeGCryptRemoteUUID dir)
+ =<< liftAnnex (probeGCryptRemoteUUID $ fromOsPath dir)
Just driveuuid -> isknownuuid driveuuid
, newrepo
)
where
go (RepoKey keyid) = whenGcryptInstalled $ makewith $ const $ do
r <- liftAnnex $ addRemote $
- makeGCryptRemote remotename dir keyid
+ makeGCryptRemote remotename (fromOsPath dir) keyid
return (Types.Remote.uuid r, r)
- go NoRepoKey = checkGCryptRepoEncryption dir makeunencrypted makeunencrypted $ do
- mu <- liftAnnex $ probeGCryptRemoteUUID dir
+ go NoRepoKey = checkGCryptRepoEncryption (fromOsPath dir) makeunencrypted makeunencrypted $ do
+ mu <- liftAnnex $ probeGCryptRemoteUUID (fromOsPath dir)
case mu of
Just u -> enableexistinggcryptremote u
Nothing -> giveup "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported."
enableexistinggcryptremote u = do
- remotename' <- liftAnnex $ getGCryptRemoteName u dir
+ remotename' <- liftAnnex $ getGCryptRemoteName u (fromOsPath dir)
makewith $ const $ do
r <- liftAnnex $ addRemote $
enableSpecialRemote remotename' GCrypt.remote Nothing $ M.fromList
- [(Proposed "gitrepo", Proposed dir)]
+ [(Proposed "gitrepo", Proposed (fromOsPath dir))]
return (u, r)
{- Making a new unencrypted repo, or combining with an existing one. -}
makeunencrypted = makewith $ \isnew -> (,)
liftAnnex $ defaultStandardGroup u TransferGroup
liftAssistant $ immediateSyncRemote r
redirect $ EditNewRepositoryR u
- mountpoint = T.unpack (mountPoint drive)
+ mountpoint = toOsPath $ T.unpack (mountPoint drive)
dir = removableDriveRepository drive
- remotename = takeFileName mountpoint
+ remotename = fromOsPath $ takeFileName mountpoint
{- Each repository is made a remote of the other.
- Next call syncRemote to get them in sync. -}
-combineRepos :: FilePath -> String -> Handler Remote
+combineRepos :: OsPath -> String -> Handler Remote
combineRepos dir name = liftAnnex $ do
hostname <- fromMaybe "host" <$> liftIO getHostname
- mylocation <- fromRepo Git.repoLocation
- mypath <- liftIO $ fromRawFilePath <$> relPathDirToFile
- (toRawFilePath dir)
- (toRawFilePath mylocation)
- liftIO $ inDir dir $ void $ makeGitRemote hostname mypath
- addRemote $ makeGitRemote name dir
+ mylocation <- fromRepo Git.repoPath
+ mypath <- liftIO $ relPathDirToFile dir mylocation
+ liftIO $ inDir dir $ void $ makeGitRemote hostname (fromOsPath mypath)
+ addRemote $ makeGitRemote name (fromOsPath dir)
getEnableDirectoryR :: UUID -> Handler Html
getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do
genRemovableDrive dir = RemovableDrive
<$> getDiskFree dir
<*> pure (T.pack dir)
- <*> pure (T.pack gitAnnexAssistantDefaultDir)
+ <*> pure (T.pack $ fromOsPath gitAnnexAssistantDefaultDir)
{- Bootstraps from first run mode to a fully running assistant in a
- repository, by running the postFirstRun callback, which returns the
- url to the new webapp. -}
-startFullAssistant :: FilePath -> StandardGroup -> Maybe (Annex ())-> Handler ()
+startFullAssistant :: OsPath -> StandardGroup -> Maybe (Annex ())-> Handler ()
startFullAssistant path repogroup setup = do
webapp <- getYesod
url <- liftIO $ do
-
- The directory may be in the process of being created; if so
- the parent directory is checked instead. -}
-canWrite :: FilePath -> IO Bool
+canWrite :: OsPath -> IO Bool
canWrite dir = do
tocheck <- ifM (doesDirectoryExist dir)
( return dir
- , return $ fromRawFilePath $ parentDir $ toRawFilePath dir
+ , return $ parentDir dir
)
- catchBoolIO $ R.fileAccess (toRawFilePath tocheck) False True False
+ catchBoolIO $ R.fileAccess (fromOsPath tocheck) False True False
{- Gets the UUID of the git repo at a location, which may not exist, or
- not be a git-annex repo. -}
-probeUUID :: FilePath -> IO (Maybe UUID)
+probeUUID :: OsPath -> IO (Maybe UUID)
probeUUID dir = catchDefaultIO Nothing $ inDir dir $ do
u <- getUUID
return $ if u == NoUUID then Nothing else Just u
enableTor :: Handler ()
enableTor = do
- gitannex <- liftIO programPath
+ gitannex <- fromOsPath <$> liftIO programPath
(transcript, ok) <- liftIO $ processTranscript gitannex ["enable-tor"] Nothing
if ok
-- Reload remotedameon so it's serving the tor hidden
postFinishLocalPairR :: PairMsg -> Handler Html
#ifdef WITH_PAIRING
postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
- repodir <- liftH $ fromRawFilePath . repoPath <$> liftAnnex gitRepo
+ repodir <- liftH $ repoPath <$> liftAnnex gitRepo
liftIO $ setup repodir
startLocalPairing PairAck (cleanup repodir) alert uuid "" secret
where
import Assistant.Upgrade
import qualified Data.Text as T
-import qualified System.FilePath.ByteString as P
data PrefsForm = PrefsForm
{ diskReserve :: Text
unsetConfig (annexConfig "numcopies") -- deprecated
setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p)
unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do
- here <- fromRawFilePath <$> fromRepo Git.repoPath
+ here <- fromRepo Git.repoPath
liftIO $ if autoStart p
then addAutoStartFile here
else removeAutoStartFile here
inAutoStartFile :: Annex Bool
inAutoStartFile = do
here <- liftIO . absPath =<< fromRepo Git.repoPath
- any (`P.equalFilePath` here) . map toRawFilePath
- <$> liftIO readAutoStartFile
+ any (`equalFilePath` here) <$> liftIO readAutoStartFile
, sshDirectory = fromMaybe "" $ inputDirectory s
, sshRepoName = genSshRepoName
(T.unpack $ fromJust $ inputHostname s)
- (maybe "" T.unpack $ inputDirectory s)
+ (toOsPath (maybe "" T.unpack $ inputDirectory s))
, sshPort = inputPort s
, needsPubKey = False
, sshCapabilities = [] -- untested
<*> aopt check_username (bfs "User name") (Just $ inputUsername d)
<*> areq (selectFieldList authmethods) (bfs "Authenticate with") (Just $ inputAuthMethod d)
<*> aopt passwordField (bfs "Password") Nothing
- <*> aopt textField (bfs "Directory") (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ inputDirectory d)
+ <*> aopt textField (bfs "Directory") (Just $ Just $ fromMaybe (T.pack $ fromOsPath gitAnnexAssistantDefaultDir) $ inputDirectory d)
<*> areq intField (bfs "Port") (Just $ inputPort d)
authmethods :: [(Text, AuthMethod)]
v <- getCachedCred login
liftIO $ case v of
Nothing -> go [passwordprompts 0] Nothing
- Just pass -> withTmpFile (toOsPath "ssh") $ \passfile h -> do
+ Just pass -> withTmpFile (literalOsPath "ssh") $ \passfile h -> do
hClose h
- writeFileProtected (fromOsPath passfile) pass
+ writeFileProtected passfile pass
environ <- getEnvironment
let environ' = addEntries
- [ ("SSH_ASKPASS", program)
- , (sshAskPassEnv, fromRawFilePath $ fromOsPath passfile)
+ [ ("SSH_ASKPASS", fromOsPath program)
+ , (sshAskPassEnv, fromOsPath passfile)
, ("DISPLAY", ":0")
] environ
go [passwordprompts 1] (Just environ')
]
, if needsinit then Just (wrapCommand "git annex init") else Nothing
, if needsPubKey origsshdata
- then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) remotedir . sshPubKey <$> keypair
+ then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) (toOsPath remotedir) . sshPubKey <$> keypair
else Nothing
]
rsynconly = onlyCapability origsshdata RsyncCapable
|]
go sshinput = do
let reponame = genSshRepoName "rsync.net"
- (maybe "" T.unpack $ inputDirectory sshinput)
+ (toOsPath (maybe "" T.unpack $ inputDirectory sshinput))
prepRsyncNet sshinput reponame $ \sshdata -> inpage $
checkExistingGCrypt sshdata $ do
redirect ConfigurationR
_ -> do
munuseddesc <- liftAssistant describeUnused
- ts <- liftAnnex $ dateUnusedLog ""
+ ts <- liftAnnex $ dateUnusedLog (literalOsPath "")
mlastchecked <- case ts of
Nothing -> pure Nothing
Just t -> Just <$> liftIO (durationSince t)
getLogR :: Handler Html
getLogR = page "Logs" Nothing $ do
logfile <- liftAnnex $ fromRepo gitAnnexDaemonLogFile
- logs <- liftIO $ listLogs (fromRawFilePath logfile)
+ logs <- liftIO $ listLogs (fromOsPath logfile)
logcontent <- liftIO $ concat <$> mapM readFile logs
$(widgetFile "control/log")
transferPaused info || isNothing (startedTime info)
desc transfer info = case associatedFile info of
AssociatedFile Nothing -> serializeKey $ transferKey transfer
- AssociatedFile (Just af) -> fromRawFilePath af
+ AssociatedFile (Just af) -> fromOsPath af
{- Simplifies a list of transfers, avoiding display of redundant
- equivalent transfers. -}
- blocking the response to the browser on it. -}
openFileBrowser :: Handler Bool
openFileBrowser = do
- path <- fromRawFilePath
+ path <- fromOsPath
<$> (liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath))
#ifdef darwin_HOST_OS
let cmd = "open"
{- The full license info may be included in a file on disk that can
- be read in and displayed. -}
-licenseFile :: IO (Maybe FilePath)
+licenseFile :: IO (Maybe OsPath)
licenseFile = do
base <- standaloneAppBase
- return $ (</> "LICENSE") <$> base
+ return $ (</> literalOsPath "LICENSE") <$> base
getAboutR :: Handler Html
getAboutR = page "About git-annex" (Just About) $ do
Just f -> customPage (Just About) $ do
-- no sidebar, just pages of legalese..
setTitle "License"
- license <- liftIO $ readFile f
+ license <- liftIO $ readFile (fromOsPath f)
$(widgetFile "documentation/license")
getRepoGroupR :: Handler Html
import Config.Files.AutoStart
import Utility.Yesod
import Assistant.Restart
-import qualified Utility.RawFilePath as R
getRepositorySwitcherR :: Handler Html
getRepositorySwitcherR = page "Switch repository" Nothing $ do
listOtherRepos :: IO [(String, String)]
listOtherRepos = do
dirs <- readAutoStartFile
- pwd <- R.getCurrentDirectory
+ pwd <- getCurrentDirectory
gooddirs <- filterM isrepo $
- filter (\d -> not $ toRawFilePath d `dirContains` pwd) dirs
+ filter (\d -> not $ d `dirContains` pwd) dirs
names <- mapM relHome gooddirs
- return $ sort $ zip names gooddirs
+ return $ sort $ zip (map fromOsPath names) (map fromOsPath gooddirs)
where
- isrepo d = doesDirectoryExist (d </> ".git")
+ isrepo d = doesDirectoryExist (d </> literalOsPath ".git")
getSwitchToRepositoryR :: FilePath -> Handler Html
getSwitchToRepositoryR repo = do
- liftIO $ addAutoStartFile repo -- make this the new default repo
- redirect =<< liftIO (newAssistantUrl repo)
+ let repo' = toOsPath repo
+ liftIO $ addAutoStartFile repo' -- make this the new default repo
+ redirect =<< liftIO (newAssistantUrl repo')
Nothing -> giveup $ "Cannot generate a key for backend " ++
decodeBS (formatKeyVariety (B.backendVariety b))
-getBackend :: FilePath -> Key -> Annex (Maybe Backend)
+getBackend :: OsPath -> Key -> Annex (Maybe Backend)
getBackend file k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
Just backend -> return $ Just backend
Nothing -> do
- warning $ "skipping " <> QuotedPath (toRawFilePath file) <> " (" <>
+ warning $ "skipping " <> QuotedPath file <> " (" <>
UnquotedString (unknownBackendVarietyMessage (fromKey keyVariety k)) <> ")"
return Nothing
{- Looks up the backend that should be used for a file.
- That can be configured on a per-file basis in the gitattributes file,
- or forced with --backend. -}
-chooseBackend :: RawFilePath -> Annex Backend
+chooseBackend :: OsPath -> Annex Backend
chooseBackend f = Annex.getRead Annex.forcebackend >>= go
where
go Nothing = do
withExternalState ebname hasext $ \st ->
handleRequest st req notavail go
where
- req = GENKEY (fromRawFilePath (contentLocation ks))
+ req = GENKEY (fromOsPath (contentLocation ks))
notavail = giveup $ "Cannot generate a key, since " ++ externalBackendProgram ebname ++ " is not available."
go (GENKEY_SUCCESS pk) = Just $ Result <$> fromProtoKey pk hasext ks
return $ GetNextMessage go
go _ = Nothing
-verifyKeyContentExternal :: ExternalBackendName -> HasExt -> MeterUpdate -> Key -> RawFilePath -> Annex Bool
+verifyKeyContentExternal :: ExternalBackendName -> HasExt -> MeterUpdate -> Key -> OsPath -> Annex Bool
verifyKeyContentExternal ebname hasext meterupdate k f =
withExternalState ebname hasext $ \st ->
handleRequest st req notavail go
where
- req = VERIFYKEYCONTENT (toProtoKey k) (fromRawFilePath f)
+ req = VERIFYKEYCONTENT (toProtoKey k) (fromOsPath f)
-- This should not be able to happen, because CANVERIFY is checked
-- before this function is enable, and so the external program
expected = reverse $ takeWhile (/= '-') $ reverse $
decodeBS $ S.fromShort $ fromKey keyName key
-genGitBundleKey :: UUID -> RawFilePath -> MeterUpdate -> Annex Key
+genGitBundleKey :: UUID -> OsPath -> MeterUpdate -> Annex Key
genGitBundleKey remoteuuid file meterupdate = do
filesize <- liftIO $ getFileSize file
s <- Hash.hashFile hash file meterupdate
keyValue hash source meterupdate
>>= addE source (const $ hashKeyVariety hash (HasExt True))
-checkKeyChecksum :: (Key -> String -> Bool) -> Hash -> Key -> RawFilePath -> Annex Bool
+checkKeyChecksum :: (Key -> String -> Bool) -> Hash -> Key -> OsPath -> Annex Bool
checkKeyChecksum issame hash key file = catchIOErrorType HardwareFault hwfault $ do
showAction (UnquotedString descChecksum)
issame key
AssociatedFile Nothing -> Nothing
AssociatedFile (Just file) -> Just $ alterKey oldkey $ \d -> d
{ keyName = S.toShort $ keyHash oldkey
- <> selectExtension maxextlen maxexts file
+ <> selectExtension maxextlen maxexts (fromOsPath file)
, keyVariety = newvariety
}
{- Upgrade to fix bad previous migration that created a
oldvariety = fromKey keyVariety oldkey
newvariety = backendVariety newbackend
-hashFile :: Hash -> RawFilePath -> MeterUpdate -> Annex String
+hashFile :: Hash -> OsPath -> MeterUpdate -> Annex String
hashFile hash file meterupdate =
- liftIO $ withMeteredFile (fromRawFilePath file) meterupdate $ \b -> do
+ liftIO $ withMeteredFile file meterupdate $ \b -> do
let h = (fst $ hasher hash) b
-- Force full evaluation of hash so whole file is read
-- before returning.
let ext = selectExtension
(annexMaxExtensionLength c)
(annexMaxExtensions c)
- (keyFilename source)
+ (fromOsPath (keyFilename source))
return $ alterKey k $ \d -> d
{ keyName = keyName d <> S.toShort ext
, keyVariety = sethasext (keyVariety d)
| otherwise = return Nothing
-- The Backend must use a cryptographically secure hash.
-generateEquivilantKey :: Backend -> RawFilePath -> Annex (Maybe Key)
+generateEquivilantKey :: Backend -> OsPath -> Annex (Maybe Key)
generateEquivilantKey b f =
case genKey b of
Just genkey -> do
keyValue :: KeySource -> MeterUpdate -> Annex Key
keyValue source _ = do
let f = contentLocation source
- stat <- liftIO $ R.getFileStatus f
+ stat <- liftIO $ R.getFileStatus (fromOsPath f)
sz <- liftIO $ getFileSize' f stat
- relf <- fromRawFilePath . getTopFilePath
+ relf <- fromOsPath . getTopFilePath
<$> inRepo (toTopFilePath $ keyFilename source)
return $ mkKey $ \k -> k
{ keyName = genKeyName relf
import Utility.Env.Basic
import qualified Git.Version
import Utility.SystemDirectory
+import Utility.OsPath
import Control.Monad
import Control.Applicative
setup :: IO ()
setup = do
- createDirectoryIfMissing True tmpDir
+ createDirectoryIfMissing True (toOsPath tmpDir)
writeFile testFile "test file contents"
cleanup :: IO ()
-cleanup = removeDirectoryRecursive tmpDir
+cleanup = removeDirectoryRecursive (toOsPath tmpDir)
run :: [TestCase] -> IO ()
run ts = do
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Build.DesktopFile where
-import Utility.Exception
+import Common
import Utility.FreeDesktop
-import Utility.Path
-import Utility.Monad
-import Utility.SystemDirectory
-import Utility.FileSystemEncoding
import Config.Files
import Utility.OSX
import Assistant.Install.AutoStart
import System.Environment
#ifndef mingw32_HOST_OS
import System.Posix.User
-import Data.Maybe
-import Control.Applicative
import Prelude
#endif
systemwideInstall = return False
#endif
-inDestDir :: FilePath -> IO FilePath
+inDestDir :: OsPath -> IO OsPath
inDestDir f = do
destdir <- catchDefaultIO "" (getEnv "DESTDIR")
- return $ destdir ++ "/" ++ f
+ return $ toOsPath destdir <> literalOsPath "/" <> f
writeFDODesktop :: FilePath -> IO ()
writeFDODesktop command = do
datadir <- if systemwide then return systemDataDir else userDataDir
menufile <- inDestDir (desktopMenuFilePath "git-annex" datadir)
icondir <- inDestDir (iconDir datadir)
- installMenu command menufile "doc" icondir
+ installMenu command menufile (literalOsPath "doc") icondir
configdir <- if systemwide then return systemConfigDir else userConfigDir
installAutoStart command
( return ()
, do
programfile <- inDestDir =<< programFile
- createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath programfile)))
- writeFile programfile command
+ createDirectoryIfMissing True (parentDir programfile)
+ writeFile (fromOsPath programfile) command
)
installUser :: FilePath -> IO ()
import Utility.FileMode
import Utility.CopyFile
import Utility.FileSystemEncoding
+import Utility.SystemDirectory
mklibs :: FilePath -> a -> IO Bool
mklibs top _installedbins = do
- fs <- dirContentsRecursive top
- exes <- filterM checkExe fs
+ fs <- dirContentsRecursive (toRawFilePath top)
+ exes <- filterM checkExe (map fromRawFilePath fs)
libs <- runLdd exes
glibclibs <- glibcLibs
import Utility.Directory
import Utility.Env
import Utility.FileSystemEncoding
+import Utility.SystemDirectory
import Build.BundledPrograms
#ifdef darwin_HOST_OS
import System.IO
-- install git-core programs; these are run by the git command
createDirectoryIfMissing True gitcoredestdir
execpath <- getgitpath "exec-path"
- cfs <- dirContents execpath
+ cfs <- dirContents (toRawFilePath execpath)
forM_ cfs $ \f -> do
+ let f' = fromRawFilePath f
destf <- ((gitcoredestdir </>) . fromRawFilePath)
<$> relPathDirToFile
(toRawFilePath execpath)
- (toRawFilePath f)
+ f
createDirectoryIfMissing True (takeDirectory destf)
- issymlink <- isSymbolicLink <$> getSymbolicLinkStatus f
+ issymlink <- isSymbolicLink <$> getSymbolicLinkStatus f'
if issymlink
then do
-- many git-core files may symlink to eg
-- Other git-core files symlink to a file
-- beside them in the directory. Those
-- links can be copied as-is.
- linktarget <- readSymbolicLink f
+ linktarget <- readSymbolicLink f'
if takeFileName linktarget == linktarget
- then cp f destf
+ then cp f' destf
else do
let linktarget' = progDir topdir </> takeFileName linktarget
unlessM (doesFileExist linktarget') $ do
createDirectoryIfMissing True (takeDirectory linktarget')
- L.readFile f >>= L.writeFile linktarget'
+ L.readFile f' >>= L.writeFile linktarget'
removeWhenExistsWith removeLink destf
rellinktarget <- relPathDirToFile
(toRawFilePath (takeDirectory destf))
(toRawFilePath linktarget')
createSymbolicLink (fromRawFilePath rellinktarget) destf
- else cp f destf
+ else cp f' destf
-- install git's template files
-- git does not have an option to get the path of these,
-- next to the --man-path, in eg /usr/share/git-core
manpath <- getgitpath "man-path"
let templatepath = manpath </> ".." </> "git-core" </> "templates"
- tfs <- dirContents templatepath
+ tfs <- dirContents (toRawFilePath templatepath)
forM_ tfs $ \f -> do
destf <- ((templatedestdir </>) . fromRawFilePath)
<$> relPathDirToFile
(toRawFilePath templatepath)
- (toRawFilePath f)
+ f
createDirectoryIfMissing True (takeDirectory destf)
- cp f destf
+ cp (fromRawFilePath f) destf
where
gitcoredestdir = topdir </> "git-core"
templatedestdir = topdir </> "templates"
import Utility.Monad
import Utility.SafeCommand
import Utility.SystemDirectory
+import Utility.OsPath
import System.IO
-import System.FilePath
type ConfigKey = String
data ConfigValue =
)
where
find d =
- let f = d </> command
- in ifM (doesFileExist f) ( return (Just f), return Nothing )
+ let f = toOsPath d </> toOsPath command
+ in ifM (doesFileExist f)
+ ( return (Just (fromOsPath f))
+ , return Nothing
+ )
quiet :: String -> String
quiet s = s ++ " >/dev/null 2>&1"
, ""
]
footer = []
- f = toOsPath "Build/Version"
+ f = literalOsPath "Build/Version"
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module CmdLine (
dispatch,
usage,
import Annex.Environment
import Command
import Types.Messages
+import qualified Utility.OsString as OS
{- Parses input arguments, finds a matching Command, and runs it. -}
dispatch :: Bool -> Bool -> CmdParams -> [Command] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO ()
findAddonCommand (Just subcommandname) =
searchPath c >>= \case
Nothing -> return Nothing
- Just p -> return (Just (mkAddonCommand p subcommandname))
+ Just p -> return (Just (mkAddonCommand (fromOsPath p) subcommandname))
where
c = "git-annex-" ++ subcommandname
findAllAddonCommands :: IO [Command]
findAllAddonCommands =
filter isaddoncommand
- . map (\p -> mkAddonCommand p (deprefix p))
- <$> searchPathContents ("git-annex-" `isPrefixOf`)
+ . map go
+ <$> searchPathContents (literalOsPath "git-annex-" `OS.isPrefixOf`)
where
- deprefix = replace "git-annex-" "" . takeFileName
+ go p = mkAddonCommand (fromOsPath p) (deprefix p)
+ deprefix = replace "git-annex-" "" . fromOsPath . takeFileName
isaddoncommand c
-- git-annex-shell
| cmdname c == "shell" = False
-- to handle them.
--
-- File matching options are checked, and non-matching files skipped.
-batchFiles :: BatchFormat -> ((SeekInput, RawFilePath) -> CommandStart) -> Annex ()
+batchFiles :: BatchFormat -> ((SeekInput, OsPath) -> CommandStart) -> Annex ()
batchFiles fmt a = batchFilesKeys fmt $ \(si, v) -> case v of
Right f -> a (si, f)
Left _k -> return Nothing
-batchFilesKeys :: BatchFormat -> ((SeekInput, Either Key RawFilePath) -> CommandStart) -> Annex ()
+batchFilesKeys :: BatchFormat -> ((SeekInput, Either Key OsPath) -> CommandStart) -> Annex ()
batchFilesKeys fmt a = do
matcher <- getMatcher
go $ \si v -> case v of
-- CmdLine.Seek uses git ls-files.
BatchFormat _ (BatchKeys False) ->
Right . Right
- <$$> liftIO . relPathCwdToFile . toRawFilePath
+ <$$> liftIO . relPathCwdToFile . toOsPath
BatchFormat _ (BatchKeys True) -> \i ->
pure $ case deserializeKey i of
Just k -> Right (Left k)
"Restricted login shell for git-annex only SSH access"
where
mkrepo = do
- r <- Git.Construct.repoAbsPath (toRawFilePath dir)
+ r <- Git.Construct.repoAbsPath (toOsPath dir)
>>= Git.Construct.fromAbsPath
let r' = r { repoPathSpecifiedExplicitly = True }
Git.Config.read r'
v <- getEnv "GIT_ANNEX_SHELL_DIRECTORY"
case (v, mdir) of
(Nothing, _) -> noop
- (Just d, Nothing) -> req d Nothing
+ (Just d, Nothing) -> req (toOsPath d) Nothing
(Just d, Just dir)
- | d `equalFilePath` dir -> noop
+ | toOsPath d `equalFilePath` toOsPath dir -> noop
| otherwise -> do
home <- myHomeDir
d' <- canondir home d
where
req d mdir' = giveup $ unwords
[ "Only allowed to access"
- , d
- , maybe "and could not determine directory from command line" ("not " ++) mdir'
+ , fromOsPath d
+ , maybe "and could not determine directory from command line"
+ (("not " ++) . fromOsPath)
+ mdir'
]
{- A directory may start with ~/ or in some cases, even /~/,
- or could just be relative to home, or of course could
- be absolute. -}
canondir home d
- | "~/" `isPrefixOf` d = return d
- | "/~/" `isPrefixOf` d = return $ drop 1 d
- | otherwise = relHome $ fromRawFilePath $ absPathFrom
- (toRawFilePath home)
- (toRawFilePath d)
+ | "~/" `isPrefixOf` d = return $ toOsPath d
+ | "/~/" `isPrefixOf` d = return $ toOsPath $ drop 1 d
+ | otherwise = relHome $ absPathFrom
+ (toOsPath home)
+ (toOsPath d)
{- Modifies a Command to check that it is run in either a git-annex
- repository, or a repository with a gcrypt-id set. -}
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.Map.Strict as M
-import qualified System.FilePath.ByteString as P
import qualified Data.Set as S
run :: [String] -> IO ()
else downloadManifestOrFail rmt
l <- forM (inManifest manifest) $ \k -> do
b <- downloadGitBundle rmt k
- heads <- inRepo $ Git.Bundle.listHeads b
+ let b' = fromOsPath b
+ heads <- inRepo $ Git.Bundle.listHeads b'
-- Get all the objects from the bundle. This is done here
-- so that the tracking refs can be updated with what is
-- listed, and so what when a full repush is done, all
-- objects are available to be pushed.
when forpush $
- inRepo $ Git.Bundle.unbundle b
+ inRepo $ Git.Bundle.unbundle b'
-- The bundle may contain tracking refs, or regular refs,
-- make sure we're operating on regular refs.
return $ map (\(s, r) -> (fromTrackingRef rmt r, s)) heads
fetch' st rmt = do
manifest <- maybe (downloadManifestOrFail rmt) pure (manifestCache st)
forM_ (inManifest manifest) $ \k ->
- downloadGitBundle rmt k >>= inRepo . Git.Bundle.unbundle
+ downloadGitBundle rmt k
+ >>= inRepo . Git.Bundle.unbundle . fromOsPath
-- Newline indicates end of fetch.
liftIO $ do
putStrLn ""
resolveSpecialRemoteWebUrl url
| "http://" `isPrefixOf` lcurl || "https://" `isPrefixOf` lcurl =
Url.withUrlOptionsPromptingCreds $ \uo ->
- withTmpFile (toOsPath "git-remote-annex") $ \tmp h -> do
+ withTmpFile (literalOsPath "git-remote-annex") $ \tmp h -> do
liftIO $ hClose h
- let tmp' = fromRawFilePath $ fromOsPath tmp
- Url.download' nullMeterUpdate Nothing url tmp' uo >>= \case
+ Url.download' nullMeterUpdate Nothing url tmp uo >>= \case
Left err -> giveup $ url ++ " " ++ err
Right () -> liftIO $
fmap decodeBS
-- it needs to re-download it fresh every time, and the object
-- file should not be stored locally.
gettotmp dl = withOtherTmp $ \othertmp ->
- withTmpFileIn (toOsPath othertmp) (toOsPath "GITMANIFEST") $ \tmp tmph -> do
+ withTmpFileIn othertmp (literalOsPath "GITMANIFEST") $ \tmp tmph -> do
liftIO $ hClose tmph
- _ <- dl (fromRawFilePath (fromOsPath tmp))
+ _ <- dl tmp
b <- liftIO (F.readFile' tmp)
case parseManifest b of
Right m -> Just <$> verifyManifest rmt m
dropKey' rmt mk
put mk
- put mk = withTmpFile (toOsPath "GITMANIFEST") $ \tmp tmph -> do
+ put mk = withTmpFile (literalOsPath "GITMANIFEST") $ \tmp tmph -> do
liftIO $ B8.hPut tmph (formatManifest manifest)
liftIO $ hClose tmph
-- Uploading needs the key to be in the annex objects
-- keys, which it is not.
objfile <- calcRepo (gitAnnexLocation mk)
modifyContentDir objfile $
- linkOrCopy mk (fromOsPath tmp) objfile Nothing >>= \case
+ linkOrCopy mk tmp objfile Nothing >>= \case
-- Important to set the right perms even
-- though the object is only present
-- briefly, since sending objects may rely
-- on or even copy file perms.
Just _ -> do
- liftIO $ R.setFileMode objfile
+ liftIO $ R.setFileMode (fromOsPath objfile)
=<< defaultFileMode
freezeContent objfile
Nothing -> uploadfailed
- interrupted before updating the manifest on the remote, or when a race
- causes the uploaded manigest to be overwritten.
-}
-lastPushedManifestFile :: UUID -> Git.Repo -> RawFilePath
-lastPushedManifestFile u r = gitAnnexDir r P.</> "git-remote-annex"
- P.</> fromUUID u P.</> "manifest"
+lastPushedManifestFile :: UUID -> Git.Repo -> OsPath
+lastPushedManifestFile u r = gitAnnexDir r
+ </> literalOsPath "git-remote-annex"
+ </> fromUUID u
+ </> literalOsPath "manifest"
{- Call before uploading anything. The returned manifest has added
- to it any bundle keys that were in the lastPushedManifestFile
f <- fromRepo (lastPushedManifestFile (Remote.uuid rmt))
oldmanifest <- liftIO $
fromRight mempty . parseManifest
- <$> F.readFile' (toOsPath f)
+ <$> F.readFile' f
`catchNonAsync` (const (pure mempty))
let oldmanifest' = mkManifest [] $
S.fromList (inManifest oldmanifest)
-- and so more things pulled from it, etc.
-- 3. Git bundle objects are not usually transferred between repositories
-- except special remotes (although the user can if they want to).
-downloadGitBundle :: Remote -> Key -> Annex FilePath
+downloadGitBundle :: Remote -> Key -> Annex OsPath
downloadGitBundle rmt k = getKeyExportLocations rmt k >>= \case
Nothing -> dlwith $
download rmt k (AssociatedFile Nothing) stdRetry noNotification
anyM getexport locs
where
dlwith a = ifM a
- ( decodeBS <$> calcRepo (gitAnnexLocation k)
+ ( calcRepo (gitAnnexLocation k)
, giveup $ "Failed to download " ++ serializeKey k
)
getexport' loc =
getViaTmp rsp vc k (AssociatedFile Nothing) Nothing $ \tmp -> do
v <- Remote.retrieveExport (Remote.exportActions rmt)
- k loc (decodeBS tmp) nullMeterUpdate
+ k loc tmp nullMeterUpdate
return (True, v)
rsp = Remote.retrievalSecurityPolicy rmt
vc = Remote.RemoteVerify rmt
uploadGitObject :: Remote -> Key -> Annex ()
uploadGitObject rmt k = getKeyExportLocations rmt k >>= \case
Just (loc:_) -> do
- objfile <- fromRawFilePath <$> calcRepo (gitAnnexLocation k)
+ objfile <- calcRepo (gitAnnexLocation k)
Remote.storeExport (Remote.exportActions rmt) objfile k loc nullMeterUpdate
_ ->
unlessM (upload rmt k (AssociatedFile Nothing) retry noNotification) $
-> Manifest
-> Annex (Key, Annex ())
generateGitBundle rmt bs manifest =
- withTmpFile (toOsPath "GITBUNDLE") $ \tmp tmph -> do
- let tmp' = fromOsPath tmp
+ withTmpFile (literalOsPath "GITBUNDLE") $ \tmp tmph -> do
liftIO $ hClose tmph
- inRepo $ Git.Bundle.create (fromRawFilePath tmp') bs
+ inRepo $ Git.Bundle.create (fromOsPath tmp) bs
bundlekey <- genGitBundleKey (Remote.uuid rmt)
- tmp' nullMeterUpdate
+ tmp nullMeterUpdate
if (bundlekey `notElem` inManifest manifest)
then do
- unlessM (moveAnnex bundlekey (AssociatedFile Nothing) tmp') $
+ unlessM (moveAnnex bundlekey (AssociatedFile Nothing) tmp) $
giveup "Unable to push"
return (bundlekey, uploadaction bundlekey)
else return (bundlekey, noop)
keyExportLocations :: Remote -> Key -> GitConfig -> UUID -> Maybe [ExportLocation]
keyExportLocations rmt k cfg uuid
| exportTree (Remote.config rmt) || importTree (Remote.config rmt) =
- Just $ map (\p -> mkExportLocation (".git" P.</> p)) $
+ Just $ map (\p -> mkExportLocation (literalOsPath ".git" </> p)) $
concatMap (`annexLocationsBare` k) cfgs
| otherwise = Nothing
where
Nothing -> fixup <$> Git.CurrentRepo.get
where
fixup r@(Repo { location = loc@(Local { worktree = Just _ }) }) =
- r { location = loc { worktree = Just (P.takeDirectory (gitdir loc)) } }
+ r { location = loc { worktree = Just (takeDirectory (gitdir loc)) } }
fixup r = r
-- Records what the git-annex branch was at the beginning of this command.
-- journal writes to a temporary directory, so that all writes
-- to the git-annex branch by the action will be discarded.
specialRemoteFromUrl :: StartAnnexBranch -> Annex a -> Annex a
-specialRemoteFromUrl sab a = withTmpDir (toOsPath "journal") $ \tmpdir -> do
+specialRemoteFromUrl sab a = withTmpDir (literalOsPath "journal") $ \tmpdir -> do
Annex.overrideGitConfig $ \c ->
c { annexAlwaysCommit = False }
Annex.BranchState.changeState $ \st ->
- st { alternateJournal = Just (toRawFilePath tmpdir) }
+ st { alternateJournal = Just tmpdir }
a `finally` cleanupInitialization sab tmpdir
-- If the git-annex branch did not exist when this command started,
-- involve checking out an adjusted branch. But git clone wants to do its
-- own checkout. So no initialization is done then, and the git bundle
-- objects are deleted.
-cleanupInitialization :: StartAnnexBranch -> FilePath -> Annex ()
+cleanupInitialization :: StartAnnexBranch -> OsPath -> Annex ()
cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do
- liftIO $ mapM_ R.removeLink
- =<< dirContents (toRawFilePath alternatejournaldir)
+ liftIO $ mapM_ removeFile =<< dirContents alternatejournaldir
case sab of
AnnexBranchExistedAlready _ -> noop
AnnexBranchCreatedEmpty r ->
whenM ((r ==) <$> Annex.Branch.getBranch) $ do
indexfile <- fromRepo gitAnnexIndex
- liftIO $ removeWhenExistsWith R.removeLink indexfile
+ liftIO $ removeWhenExistsWith removeFile indexfile
-- When cloning failed and this is being
-- run as an exception is thrown, HEAD will
-- not be set to a valid value, which will
forM_ ks $ \k -> case fromKey keyVariety k of
GitBundleKey -> lockContentForRemoval k noop removeAnnex
_ -> noop
- void $ liftIO $ tryIO $ removeDirectory (decodeBS annexobjectdir)
+ void $ liftIO $ tryIO $ removeDirectory annexobjectdir
notcrippledfilesystem = not <$> probeCrippledFileSystem
import qualified Utility.RawFilePath as R
import Utility.Tuple
import Utility.HumanTime
+import qualified Utility.OsString as OS
import Control.Concurrent.Async
import Control.Concurrent.STM
import Data.IORef
import Data.Time.Clock.POSIX
import System.PosixCompat.Files (isDirectory, isSymbolicLink, deviceID, fileID)
-import qualified System.FilePath.ByteString as P
-import qualified Data.ByteString as S
data AnnexedFileSeeker = AnnexedFileSeeker
- { startAction :: Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart
+ { startAction :: Maybe KeySha -> SeekInput -> OsPath -> Key -> CommandStart
, checkContentPresent :: Maybe Bool
, usesLocationLog :: Bool
}
getfiles c [] = return (reverse c, pure True)
getfiles c (p:ps) = do
os <- seekOptions ww
- (fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toRawFilePath p]
+ (fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toOsPath p]
r <- case fs of
[f] -> do
propagateLsFilesError cleanup
return (r, pure True)
withFilesInGitAnnexNonRecursive _ _ _ NoWorkTreeItems = noop
-withFilesNotInGit :: CheckGitIgnore -> WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
+withFilesNotInGit :: CheckGitIgnore -> WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesNotInGit (CheckGitIgnore ci) ww a l = do
force <- Annex.getRead Annex.force
let include_ignored = force || not ci
seekFiltered (const (pure True)) a $
seekHelper id ww (const $ LsFiles.notInRepo [] include_ignored) l
-withPathContents :: ((RawFilePath, RawFilePath) -> CommandSeek) -> CmdParams -> CommandSeek
+withPathContents :: ((OsPath, OsPath) -> CommandSeek) -> CmdParams -> CommandSeek
withPathContents a params = do
matcher <- Limit.getMatcher
checktimelimit <- mkCheckTimeLimit
- go matcher checktimelimit params []
+ go matcher checktimelimit (map toOsPath params) []
where
go _ _ [] [] = return ()
go matcher checktimelimit (p:ps) [] =
-- fail if the path that the user provided is a broken symlink,
-- the same as it fails if the path that the user provided does not
-- exist.
- get p = ifM (isDirectory <$> R.getFileStatus p')
+ get p = ifM (isDirectory <$> R.getFileStatus (fromOsPath p))
( map (\f ->
- (f, P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f))
- <$> dirContentsRecursiveSkipping (".git" `S.isSuffixOf`) False p'
- , return [(p', P.takeFileName p')]
+ (f, makeRelative (takeDirectory (dropTrailingPathSeparator p)) f))
+ <$> dirContentsRecursiveSkipping (literalOsPath ".git" `OS.isSuffixOf`) False p
+ , return [(p, takeFileName p)]
)
- where
- p' = toRawFilePath p
checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo
{ contentFile = f
pairs c (x:y:xs) = pairs ((x,y):c) xs
pairs _ _ = giveup "expected pairs"
-withFilesToBeCommitted :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
+withFilesToBeCommitted :: WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesToBeCommitted ww a l = seekFiltered (const (pure True)) a $
seekHelper id ww (const LsFiles.stagedNotDeleted) l
{- unlocked pointer files that are staged, and whose content has not been
- modified-}
-withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
+withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withUnmodifiedUnlockedPointers ww a l =
seekFiltered (isUnmodifiedUnlocked . snd) a $
seekHelper id ww (const LsFiles.typeChangedStaged) l
-isUnmodifiedUnlocked :: RawFilePath -> Annex Bool
+isUnmodifiedUnlocked :: OsPath -> Annex Bool
isUnmodifiedUnlocked f = catKeyFile f >>= \case
Nothing -> return False
Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k
{- Finds files that may be modified. -}
-withFilesMaybeModified :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
+withFilesMaybeModified :: WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesMaybeModified ww a params = seekFiltered (const (pure True)) a $
seekHelper id ww LsFiles.modified params
forM_ ts $ \(t, i) ->
keyaction Nothing (SeekInput [], transferKey t, mkActionItem (t, i))
-seekFiltered :: ((SeekInput, RawFilePath) -> Annex Bool) -> ((SeekInput, RawFilePath) -> CommandSeek) -> Annex ([(SeekInput, RawFilePath)], IO Bool) -> Annex ()
+seekFiltered :: ((SeekInput, OsPath) -> Annex Bool) -> ((SeekInput, OsPath) -> CommandSeek) -> Annex ([(SeekInput, OsPath)], IO Bool) -> Annex ()
seekFiltered prefilter a listfs = do
matcher <- Limit.getMatcher
checktimelimit <- mkCheckTimeLimit
-- because of the way data is streamed through git cat-file.
--
-- It can also precache location logs using the same efficient streaming.
-seekFilteredKeys :: AnnexedFileSeeker -> Annex ([(SeekInput, (RawFilePath, Git.Sha, FileMode))], IO Bool) -> Annex ()
+seekFilteredKeys :: AnnexedFileSeeker -> Annex ([(SeekInput, (OsPath, Git.Sha, FileMode))], IO Bool) -> Annex ()
seekFilteredKeys seeker listfs = do
g <- Annex.gitRepo
mi <- MatcherInfo
-- Check if files exist, because a deleted file will still be
-- listed by ls-tree, but should not be processed.
- exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p)
+ exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath p))
mdprocess mi mdreader ofeeder ocloser = liftIO mdreader >>= \case
Just ((si, f), Just (sha, size, _type))
null <$> Annex.Branch.getUnmergedRefs
| otherwise = pure False
-seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex ([(SeekInput, a)], IO Bool)
+seekHelper :: (a -> OsPath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [OsPath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex ([(SeekInput, a)], IO Bool)
seekHelper c ww a (WorkTreeItems l) = do
os <- seekOptions ww
v <- liftIO $ newIORef []
r <- inRepo $ \g -> concat . concat <$> forM (segmentXargsOrdered l)
- (runSegmentPaths' mk c (\fs -> go v os fs g) . map toRawFilePath)
+ (runSegmentPaths' mk c (\fs -> go v os fs g) . map toOsPath)
return (r, cleanupall v)
where
- mk (Just i) f = (SeekInput [fromRawFilePath i], f)
+ mk (Just i) f = (SeekInput [fromOsPath i], f)
-- This is not accurate, but it only happens when there are a
-- great many input WorkTreeItems.
- mk Nothing f = (SeekInput [fromRawFilePath (c f)], f)
+ mk Nothing f = (SeekInput [fromOsPath (c f)], f)
go v os fs g = do
(ls, cleanup) <- a os fs g
currbranch <- getCurrentBranch
stopattop <- prepviasymlink
ps' <- flip filterM ps $ \p -> do
- let p' = toRawFilePath p
+ let p' = toOsPath p
relf <- liftIO $ relPathCwdToFile p'
ifM (not <$> (exists p' <||> hidden currbranch relf))
( prob action FileNotFound p' "not found"
then return NoWorkTreeItems
else return (WorkTreeItems ps')
- exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p)
+ exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath p)
prepviasymlink = do
repotopst <- inRepo $
maybe
(pure Nothing)
- (catchMaybeIO . R.getSymbolicLinkStatus)
+ (catchMaybeIO . R.getSymbolicLinkStatus . fromOsPath)
. Git.repoWorkTree
return $ \st -> case repotopst of
Nothing -> False
viasymlink _ Nothing = return False
viasymlink stopattop (Just p) = do
- st <- liftIO $ R.getSymbolicLinkStatus p
+ st <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath p
if stopattop st
then return False
else if isSymbolicLink st
| otherwise = return False
prob action errorid p msg = do
- toplevelFileProblem False errorid msg action p Nothing (SeekInput [fromRawFilePath p])
+ toplevelFileProblem False errorid msg action p Nothing (SeekInput [fromOsPath p])
Annex.incError
return False
-notSymlink :: RawFilePath -> IO Bool
-notSymlink f = liftIO $ not . isSymbolicLink <$> R.getSymbolicLinkStatus f
+notSymlink :: OsPath -> IO Bool
+notSymlink f = liftIO $ not . isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath f)
{- Returns an action that, when there's a time limit, can be used
- to check it before processing a file. The first action is run when
noDaemonRunning = addCheck NoDaemonRunning $ whenM (isJust <$> daemonpid) $
giveup "You cannot run this command while git-annex watch or git-annex assistant is running."
where
- daemonpid = liftIO . checkDaemon . fromRawFilePath
- =<< fromRepo gitAnnexPidFile
+ daemonpid = liftIO . checkDaemon =<< fromRepo gitAnnexPidFile
dontCheck :: CommandCheck -> Command -> Command
dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c
import Annex.InodeSentinal
import Annex.CheckIgnore
import qualified Utility.RawFilePath as R
-import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (fileSize, isSymbolicLink, isRegularFile, modificationTime, fileID, deviceID, fileMode, ownerExecuteMode, intersectFileModes)
dr = dryRunOption o
{- Pass file off to git-add. -}
-startSmall :: Bool -> DryRun -> SeekInput -> RawFilePath -> CommandStart
+startSmall :: Bool -> DryRun -> SeekInput -> OsPath -> CommandStart
startSmall isdotfile dr si file =
- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case
+ liftIO (catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath file) >>= \case
Just s ->
starting "add" (ActionItemTreeFile file) si $
addSmall isdotfile dr file s
Nothing -> stop
-addSmall :: Bool -> DryRun -> RawFilePath -> FileStatus -> CommandPerform
+addSmall :: Bool -> DryRun -> OsPath -> FileStatus -> CommandPerform
addSmall isdotfile dr file s = do
showNote $ (if isdotfile then "dotfile" else "non-large file")
<> "; adding content to git repository"
skipWhenDryRun dr $ next $ addFile Small file s
-startSmallOverridden :: DryRun -> SeekInput -> RawFilePath -> CommandStart
+startSmallOverridden :: DryRun -> SeekInput -> OsPath -> CommandStart
startSmallOverridden dr si file =
- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case
+ liftIO (catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath file) >>= \case
Just s -> starting "add" (ActionItemTreeFile file) si $ do
showNote "adding content to git repository"
skipWhenDryRun dr $ next $ addFile Small file s
data SmallOrLarge = Small | Large
-addFile :: SmallOrLarge -> RawFilePath -> FileStatus -> Annex Bool
+addFile :: SmallOrLarge -> OsPath -> FileStatus -> Annex Bool
addFile smallorlarge file s = do
+ let file' = fromOsPath file
sha <- if isSymbolicLink s
- then hashBlob =<< liftIO (R.readSymbolicLink file)
+ then hashBlob =<< liftIO (R.readSymbolicLink file')
else if isRegularFile s
then hashFile file
else do
qp <- coreQuotePath <$> Annex.getGitConfig
- giveup $ decodeBS $ quote qp $
- file <> " is not a regular file"
+ giveup $ decodeBS $ quote qp file
+ <> " is not a regular file"
let treetype = if isSymbolicLink s
then TreeSymlink
else if intersectFileModes ownerExecuteMode (fileMode s) /= 0
then TreeExecutable
else TreeFile
- s' <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file
+ s' <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file'
if maybe True (changed s) s'
then do
warning $ QuotedPath file <> " changed while it was being added"
isRegularFile a /= isRegularFile b ||
isSymbolicLink a /= isSymbolicLink b
-start :: DryRun -> SeekInput -> RawFilePath -> AddUnlockedMatcher -> CommandStart
+start :: DryRun -> SeekInput -> OsPath -> AddUnlockedMatcher -> CommandStart
start dr si file addunlockedmatcher =
- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case
+ liftIO (catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath file) >>= \case
Nothing -> stop
Just s
| not (isRegularFile s) && not (isSymbolicLink s) -> stop
starting "add" (ActionItemTreeFile file) si $
addingExistingLink file key $
skipWhenDryRun dr $ withOtherTmp $ \tmp -> do
- let tmpf = tmp P.</> P.takeFileName file
+ let tmpf = tmp </> takeFileName file
liftIO $ moveFile file tmpf
- ifM (isSymbolicLink <$> liftIO (R.getSymbolicLinkStatus tmpf))
+ ifM (isSymbolicLink <$> liftIO (R.getSymbolicLinkStatus $ fromOsPath tmpf))
( do
- liftIO $ R.removeLink tmpf
+ liftIO $ removeFile tmpf
addSymlink file key Nothing
next $ cleanup key =<< inAnnex key
, do
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
next $ addFile Large file s
-perform :: RawFilePath -> AddUnlockedMatcher -> CommandPerform
+perform :: OsPath -> AddUnlockedMatcher -> CommandPerform
perform file addunlockedmatcher = withOtherTmp $ \tmpdir -> do
lockingfile <- not <$> addUnlocked addunlockedmatcher
(MatchingFile (FileInfo file file Nothing))
, hardlinkFileTmpDir = Just tmpdir
, checkWritePerms = True
}
- ld <- lockDown cfg (fromRawFilePath file)
+ ld <- lockDown cfg file
let sizer = keySource <$> ld
v <- metered Nothing sizer Nothing $ \_meter meterupdate ->
ingestAdd meterupdate ld
start = startUnused go (other "bad") (other "tmp")
where
go n key = do
- let file = "unused." <> keyFile key
+ let file = literalOsPath "unused." <> keyFile key
starting "addunused"
(ActionItemTreeFile file)
(SeekInput [show n]) $
warning (UnquotedString (show e))
next $ return False
go deffile (Right (UrlContents sz mf)) = do
- f <- maybe (pure deffile) (sanitizeOrPreserveFilePath o) mf
+ f <- maybe (pure deffile) (sanitizeOrPreserveFilePath o . fromOsPath) mf
let f' = adjustFile o (fromMaybe f (fileOption (downloadOptions o)))
void $ commandAction $ startRemote addunlockedmatcher r o si f' u sz
go deffile (Right (UrlMulti l)) = case fileOption (downloadOptions o) of
Nothing ->
forM_ l $ \(u', sz, f) -> do
- f' <- sanitizeOrPreserveFilePath o f
- let f'' = adjustFile o (deffile </> f')
+ f' <- sanitizeOrPreserveFilePath o (fromOsPath f)
+ let f'' = adjustFile o (fromOsPath (toOsPath deffile </> toOsPath f'))
void $ commandAction $ startRemote addunlockedmatcher r o si f'' u' sz
Just f -> case l of
[] -> noop
startRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> SeekInput -> FilePath -> URLString -> Maybe Integer -> CommandStart
startRemote addunlockedmatcher r o si file uri sz = do
pathmax <- liftIO $ fileNameLengthLimit "."
- let file' = P.joinPath $ map (truncateFilePath pathmax) $
+ let file' = toOsPath $ P.joinPath $ map (truncateFilePath pathmax) $
P.splitDirectories (toRawFilePath file)
startingAddUrl si uri o $ do
showNote $ UnquotedString $ "from " ++ Remote.name r
showDestinationFile file'
performRemote addunlockedmatcher r o uri file' sz
-performRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> RawFilePath -> Maybe Integer -> CommandPerform
+performRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> OsPath -> Maybe Integer -> CommandPerform
performRemote addunlockedmatcher r o uri file sz = lookupKey file >>= \case
Just k -> adduri k
Nothing -> geturi
Just n -> (True, n == fromMaybe n (fromKey keySize key), loguri)
geturi = next $ isJust <$> downloadRemoteFile addunlockedmatcher r (downloadOptions o) uri file sz
-downloadRemoteFile :: AddUnlockedMatcher -> Remote -> DownloadOptions -> URLString -> RawFilePath -> Maybe Integer -> Annex (Maybe Key)
+downloadRemoteFile :: AddUnlockedMatcher -> Remote -> DownloadOptions -> URLString -> OsPath -> Maybe Integer -> Annex (Maybe Key)
downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd o file $ \canadd -> do
let urlkey = Backend.URL.fromUrl uri sz (verifiableOption o)
createWorkTreeDirectory (parentDir file)
f <- sanitizeOrPreserveFilePath o sf
if preserveFilenameOption (downloadOptions o)
then pure f
- else ifM (liftIO $ doesFileExist f <||> doesDirectoryExist f)
+ else ifM (liftIO $ doesFileExist (toOsPath f) <||> doesDirectoryExist (toOsPath f))
( pure $ url2file url (pathdepthOption o) pathmax
, pure f
)
_ -> pure $ url2file url (pathdepthOption o) pathmax
- performWeb addunlockedmatcher o urlstring (toRawFilePath file) urlinfo
+ performWeb addunlockedmatcher o urlstring (toOsPath file) urlinfo
sanitizeOrPreserveFilePath :: AddUrlOptions -> FilePath -> Annex FilePath
sanitizeOrPreserveFilePath o f
qp <- coreQuotePath <$> Annex.getGitConfig
giveup $ decodeBS $ quote qp $
"--preserve-filename was used, but the filename ("
- <> QuotedPath (toRawFilePath f)
+ <> QuotedPath (toOsPath f)
<> ") has a security problem ("
<> d
<> "), not adding."
-performWeb :: AddUnlockedMatcher -> AddUrlOptions -> URLString -> RawFilePath -> Url.UrlInfo -> CommandPerform
+performWeb :: AddUnlockedMatcher -> AddUrlOptions -> URLString -> OsPath -> Url.UrlInfo -> CommandPerform
performWeb addunlockedmatcher o url file urlinfo = lookupKey file >>= \case
Just k -> addurl k
Nothing -> geturl
{- Check that the url exists, and has the same size as the key,
- and add it as an url to the key. -}
-addUrlChecked :: AddUrlOptions -> URLString -> RawFilePath -> UUID -> (Key -> Annex (Maybe (Bool, Bool, URLString))) -> Key -> CommandPerform
+addUrlChecked :: AddUrlOptions -> URLString -> OsPath -> UUID -> (Key -> Annex (Maybe (Bool, Bool, URLString))) -> Key -> CommandPerform
addUrlChecked o url file u checkexistssize key =
ifM ((elem url <$> getUrls key) <&&> (elem u <$> loggedLocations key))
( do
- different file, based on the title of the media. Unless the user
- specified fileOption, which then forces using the FilePath.
-}
-addUrlFile :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> RawFilePath -> Annex (Maybe Key)
+addUrlFile :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> OsPath -> Annex (Maybe Key)
addUrlFile addunlockedmatcher o url urlinfo file =
ifM (Annex.getRead Annex.fast <||> pure (relaxedOption o))
( nodownloadWeb addunlockedmatcher o url urlinfo file
, downloadWeb addunlockedmatcher o url urlinfo file
)
-downloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> RawFilePath -> Annex (Maybe Key)
+downloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> OsPath -> Annex (Maybe Key)
downloadWeb addunlockedmatcher o url urlinfo file =
go =<< downloadWith' downloader urlkey webUUID url file
where
-- so it's only used when the file contains embedded media.
tryyoutubedl tmp backend = youtubeDlFileNameHtmlOnly url >>= \case
Right mediafile -> do
- liftIO $ liftIO $ removeWhenExistsWith R.removeLink tmp
- let f = youtubeDlDestFile o file (toRawFilePath mediafile)
+ liftIO $ liftIO $ removeWhenExistsWith removeFile tmp
+ let f = youtubeDlDestFile o file mediafile
lookupKey f >>= \case
Just k -> alreadyannexed f k
Nothing -> dl f
Left err -> checkRaw (Just err) o (pure Nothing) (normalfinish tmp backend)
where
dl dest = withTmpWorkDir mediakey $ \workdir -> do
- let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)
+ let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith removeFile)
dlcmd <- youtubeDlCommand
showNote ("using " <> UnquotedString dlcmd)
Transfer.notifyTransfer Transfer.Download url $
Transfer.download' webUUID mediakey (AssociatedFile Nothing) Nothing Transfer.noRetry $ \p -> do
showDestinationFile dest
- youtubeDl url (fromRawFilePath workdir) p >>= \case
+ youtubeDl url workdir p >>= \case
Right (Just mediafile) -> do
cleanuptmp
checkCanAdd o dest $ \canadd -> do
- addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just (toRawFilePath mediafile))
+ addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just mediafile)
return $ Just mediakey
Left msg -> do
cleanuptmp
ai = OnlyActionOn urlkey (ActionItemOther (Just (UnquotedString url)))
urlkey = Backend.URL.fromUrl url Nothing (verifiableOption (downloadOptions o))
-showDestinationFile :: RawFilePath -> Annex ()
+showDestinationFile :: OsPath -> Annex ()
showDestinationFile file = do
showNote ("to " <> QuotedPath file)
- maybeShowJSON $ JSONChunk [("file", fromRawFilePath file)]
+ maybeShowJSON $ JSONChunk [("file", file)]
{- The Key should be a dummy key, based on the URL, which is used
- for this download, before we can examine the file and find its real key.
- Downloads the url, sets up the worktree file, and returns the
- real key.
-}
-downloadWith :: CanAddFile -> AddUnlockedMatcher -> (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> RawFilePath -> Annex (Maybe Key)
+downloadWith :: CanAddFile -> AddUnlockedMatcher -> (OsPath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> OsPath -> Annex (Maybe Key)
downloadWith canadd addunlockedmatcher downloader dummykey u url file =
go =<< downloadWith' downloader dummykey u url file
where
{- Like downloadWith, but leaves the dummy key content in
- the returned location. -}
-downloadWith' :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> RawFilePath -> Annex (Maybe (RawFilePath, Backend))
+downloadWith' :: (OsPath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> OsPath -> Annex (Maybe (OsPath, Backend))
downloadWith' downloader dummykey u url file =
checkDiskSpaceToGet dummykey Nothing Nothing $ do
backend <- chooseBackend file
ok <- Transfer.notifyTransfer Transfer.Download url $ \_w ->
Transfer.runTransfer t (Just backend) afile Nothing Transfer.stdRetry $ \p -> do
createAnnexDirectory (parentDir tmp)
- downloader (fromRawFilePath tmp) p
+ downloader tmp p
if ok
then return (Just (tmp, backend))
else return Nothing
where
afile = AssociatedFile (Just file)
-finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> RawFilePath -> Backend -> UUID -> URLString -> RawFilePath -> Annex Key
+finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> OsPath -> Backend -> UUID -> URLString -> OsPath -> Annex Key
finishDownloadWith canadd addunlockedmatcher tmp backend u url file = do
let source = KeySource
{ keyFilename = file
}
{- Adds worktree file to the repository. -}
-addWorkTree :: CanAddFile -> AddUnlockedMatcher -> UUID -> URLString -> RawFilePath -> Key -> Maybe RawFilePath -> Annex ()
+addWorkTree :: CanAddFile -> AddUnlockedMatcher -> UUID -> URLString -> OsPath -> Key -> Maybe OsPath -> Annex ()
addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of
Nothing -> go
Just tmp -> do
- s <- liftIO $ R.getSymbolicLinkStatus tmp
+ s <- liftIO $ R.getSymbolicLinkStatus (fromOsPath tmp)
-- Move to final location for large file check.
pruneTmpWorkDirBefore tmp $ \_ -> do
- createWorkTreeDirectory (P.takeDirectory file)
+ createWorkTreeDirectory (takeDirectory file)
liftIO $ moveFile tmp file
largematcher <- largeFilesMatcher
large <- checkFileMatcher NoLiveUpdate largematcher file
( do
when (isJust mtmp) $
logStatus NoLiveUpdate key InfoPresent
- , maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)) mtmp
+ , maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith removeFile)) mtmp
)
-nodownloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> RawFilePath -> Annex (Maybe Key)
+nodownloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> OsPath -> Annex (Maybe Key)
nodownloadWeb addunlockedmatcher o url urlinfo file
| Url.urlExists urlinfo = if rawOption o
then nomedia
else youtubeDlFileName url >>= \case
- Right mediafile -> usemedia (toRawFilePath mediafile)
+ Right mediafile -> usemedia mediafile
Left err -> checkRaw (Just err) o (pure Nothing) nomedia
| otherwise = do
warning $ UnquotedString $ "unable to access url: " ++ url
let mediakey = Backend.URL.fromUrl mediaurl Nothing (verifiableOption o)
nodownloadWeb' o addunlockedmatcher mediaurl mediakey dest
-youtubeDlDestFile :: DownloadOptions -> RawFilePath -> RawFilePath -> RawFilePath
+youtubeDlDestFile :: DownloadOptions -> OsPath -> OsPath -> OsPath
youtubeDlDestFile o destfile mediafile
| isJust (fileOption o) = destfile
- | otherwise = P.takeFileName mediafile
+ | otherwise = takeFileName mediafile
-nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> RawFilePath -> Annex (Maybe Key)
+nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> OsPath -> Annex (Maybe Key)
nodownloadWeb' o addunlockedmatcher url key file = checkCanAdd o file $ \canadd -> do
showDestinationFile file
createWorkTreeDirectory (parentDir file)
data CanAddFile = CanAddFile
-checkCanAdd :: DownloadOptions -> RawFilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a)
-checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file))
+checkCanAdd :: DownloadOptions -> OsPath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a)
+checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath file)))
( do
warning $ QuotedPath file <> " already exists; not overwriting"
return Nothing
Command.Sync.prepMerge
Command.Add.seek Command.Add.AddOptions
- { Command.Add.addThese = Command.Sync.contentOfOption o
+ { Command.Add.addThese = map fromOsPath $
+ Command.Sync.contentOfOption o
, Command.Add.batchOption = NoBatch
, Command.Add.updateOnly = False
, Command.Add.largeFilesOverride = Nothing
dirs <- liftIO readAutoStartFile
when (null dirs) $ do
f <- autoStartFile
- giveup $ "Nothing listed in " ++ f
- program <- programPath
+ giveup $ "Nothing listed in " ++ fromOsPath f
+ program <- fromOsPath <$> programPath
haveionice <- pure BuildInfo.ionice <&&> inSearchPath "ionice"
pids <- forM dirs $ \d -> do
- putStrLn $ "git-annex autostart in " ++ d
+ putStrLn $ "git-annex autostart in " ++ fromOsPath d
mpid <- catchMaybeIO $ go haveionice program d
if foregroundDaemonOption (daemonOptions o)
then return mpid
autoStop :: IO ()
autoStop = do
dirs <- liftIO readAutoStartFile
- program <- programPath
+ program <- fromOsPath <$> programPath
forM_ dirs $ \d -> do
- putStrLn $ "git-annex autostop in " ++ d
+ putStrLn $ "git-annex autostop in " ++ fromOsPath d
tryIO (setCurrentDirectory d) >>= \case
Right () -> ifM (boolSystem program [Param "assistant", Param "--stop"])
( putStrLn "ok"
Left _err -> return False
where
ks = KeySource file' file' Nothing
- file' = toRawFilePath file
+ file' = toOsPath file
| decodeBS name `elem` annexAttrs =
case forfile of
Just file -> do
- v <- checkAttr (decodeBS name) (toRawFilePath file)
+ v <- checkAttr (decodeBS name) (toOsPath file)
if null v
then cont
else showval "gitattributes" v
import Command
import Annex.Content
-import qualified Utility.RawFilePath as R
import qualified Data.ByteString.Char8 as B8
run :: () -> SeekInput -> String -> Annex Bool
run _ _ p = do
let k = fromMaybe (giveup "bad key") $ deserializeKey p
- maybe (return False) (\f -> liftIO (B8.putStrLn f) >> return True)
+ maybe (return False) emit
=<< inAnnex' (pure True) Nothing check k
where
- check f = ifM (liftIO (R.doesPathExist f))
+ check f = ifM (liftIO (doesFileExist f))
( return (Just f)
, return Nothing
)
+ emit f = liftIO $ do
+ B8.putStrLn $ fromOsPath f
+ return True
{- A copy is just a move that does not delete the source file.
- However, auto mode avoids unnecessary copies, and avoids getting or
- sending non-preferred content. -}
-start :: CopyOptions -> FromToHereOptions -> SeekInput -> RawFilePath -> Key -> CommandStart
+start :: CopyOptions -> FromToHereOptions -> SeekInput -> OsPath -> Key -> CommandStart
start o fto si file key = do
ru <- case fto of
FromOrToRemote (ToRemote dest) -> getru dest
where
getru dest = Just . Remote.uuid <$> getParsed dest
-start' :: LiveUpdate -> CopyOptions -> FromToHereOptions -> SeekInput -> RawFilePath -> Key -> CommandStart
+start' :: LiveUpdate -> CopyOptions -> FromToHereOptions -> SeekInput -> OsPath -> Key -> CommandStart
start' lu o fto si file key = stopUnless shouldCopy $
Command.Move.start lu fto Command.Move.RemoveNever si file key
where
maybe (return r) go (parseLinkTargetOrPointer =<< v)
_ -> maybe (return r) go =<< liftIO (isPointerFile f)
where
- f = toRawFilePath (getfile r)
+ f = toOsPath (getfile r)
go k = do
when (getOption opts) $
unlessM (inAnnex k) $
si = SeekInput []
af = AssociatedFile (Just f)
repoint k = withObjectLoc k $
- pure . setfile r . fromRawFilePath
+ pure . setfile r . fromOsPath
externalDiffer :: String -> [String] -> Differ
externalDiffer c ps = \req -> boolSystem c (map Param ps ++ serializeReq req )
where
ww = WarnUnmatchLsFiles "drop"
-start :: DropOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart
+start :: DropOptions -> Maybe Remote -> SeekInput -> OsPath -> Key -> CommandStart
start o from si file key = start' o from key afile ai si
where
afile = AssociatedFile (Just file)
import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
import Annex.NumCopies
import Annex.Content
-import qualified Utility.RawFilePath as R
cmd :: Command
cmd = withAnnexOptions [jobsOption, jsonOptions] $
pcc = Command.Drop.PreferredContentChecked False
ud = Command.Drop.DroppingUnused True
-performOther :: (Key -> Git.Repo -> RawFilePath) -> Key -> CommandPerform
+performOther :: (Key -> Git.Repo -> OsPath) -> Key -> CommandPerform
performOther filespec key = do
f <- fromRepo $ filespec key
- pruneTmpWorkDirBefore f (liftIO . removeWhenExistsWith R.removeLink)
+ pruneTmpWorkDirBefore f (liftIO . removeWhenExistsWith removeFile)
next $ return True
Nothing -> giveup "Need user-id parameter."
Just userid -> go userid
else starting "enable-tor" ai si $ do
- gitannex <- liftIO programPath
+ gitannex <- fromOsPath <$> liftIO programPath
let ps = [Param (cmdname cmd), Param (show curruserid)]
sucommand <- liftIO $ mkSuCommand gitannex ps
cleanenv <- liftIO $ cleanStandaloneEnvironment
haslistener sockfile = catchBoolIO $ do
soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
- S.connect soc (S.SockAddrUnix sockfile)
+ S.connect soc (S.SockAddrUnix $ fromOsPath sockfile)
S.close soc
return True
optParser = ExamineOptions
<$> optional parseFormatOption
<*> (fmap (DeferredParse . tobackend) <$> migrateopt)
- <*> (AssociatedFile <$> fileopt)
+ <*> (AssociatedFile . fmap stringToOsPath <$> fileopt)
where
fileopt = optional $ strOption
( long "filename" <> metavar paramFile
let objectpointer = formatPointer k
isterminal <- liftIO $ checkIsTerminal stdout
showFormatted isterminal (format o) (serializeKey' k) $
- [ ("objectpath", fromRawFilePath objectpath)
- , ("objectpointer", fromRawFilePath objectpointer)
+ [ ("objectpath", fromOsPath objectpath)
+ , ("objectpointer", decodeBS objectpointer)
] ++ formatVars k af
return True
where
ik = fromMaybe (giveup "bad key") (deserializeKey' ikb)
af = if B.null ifb'
then associatedFile o
- else AssociatedFile (Just ifb')
+ else AssociatedFile (Just (toOsPath ifb'))
getkey = case migrateToBackend o of
Nothing -> pure ik
-- To handle renames which swap files, the exported file is first renamed
-- to a stable temporary name based on the key.
exportTempName :: Key -> ExportLocation
-exportTempName ek = mkExportLocation $ toRawFilePath $
- ".git-annex-tmp-content-" ++ serializeKey ek
+exportTempName ek = mkExportLocation $
+ literalOsPath ".git-annex-tmp-content-" <> toOsPath (serializeKey'' ek)
seek :: ExportOptions -> CommandSeek
seek o = startConcurrency commandStages $ do
sent <- tryNonAsync $ if not (isGitShaKey ek)
then tryrenameannexobject $ sendannexobject
-- Sending a non-annexed file.
- else withTmpFile (toOsPath "export") $ \tmp h -> do
+ else withTmpFile (literalOsPath "export") $ \tmp h -> do
b <- catObject contentsha
liftIO $ L.hPut h b
liftIO $ hClose h
- Remote.action $
- storer (fromRawFilePath (fromOsPath tmp)) ek loc nullMeterUpdate
+ Remote.action $ storer tmp ek loc nullMeterUpdate
let failedsend = liftIO $ modifyMVar_ allfilledvar (pure . const (AllFilled False))
case sent of
Right True -> next $ cleanupExport r db ek loc True
import Git.UpdateIndex
import qualified Git.LsTree as LsTree
import qualified Git.Branch as Git
-import Utility.RawFilePath
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Builder
-import qualified System.FilePath.ByteString as P
cmd :: Command
cmd = noMessages $ withAnnexOptions [annexedMatchingOptions] $
seek :: FilterBranchOptions -> CommandSeek
seek o = withOtherTmp $ \tmpdir -> do
- let tmpindex = tmpdir P.</> "index"
+ let tmpindex = tmpdir </> literalOsPath "index"
gc <- Annex.getGitConfig
tmpindexrepo <- Annex.inRepo $ \r ->
- addGitEnv r indexEnv (fromRawFilePath tmpindex)
+ addGitEnv r indexEnv (fromOsPath tmpindex)
withUpdateIndex tmpindexrepo $ \h -> do
keyinfomatcher <- mkUUIDMatcher (keyInformation o)
repoconfigmatcher <- mkUUIDMatcher (repoConfig o)
-- Commit the temporary index, and output the result.
t <- liftIO $ Git.writeTree tmpindexrepo
- liftIO $ removeWhenExistsWith removeLink tmpindex
+ liftIO $ removeWhenExistsWith removeFile tmpindex
cmode <- annexCommitMode <$> Annex.getGitConfig
cmessage <- Annex.Branch.commitMessage
c <- inRepo $ Git.commitTree cmode [cmessage] [] t
go
Nothing -> return ()
-smudge :: FilePath -> Annex ()
+smudge :: OsPath -> Annex ()
smudge file = do
{- The whole git file content is necessarily buffered in memory,
- because we have to consume everything git is sending before
- See Command.Smudge.smudge for details of how this works. -}
liftIO $ respondFilterRequest b
-clean :: FilePath -> Annex ()
+clean :: OsPath -> Annex ()
clean file = do
{- We have to consume everything git is sending before we can
- respond to it. But it can be an arbitrarily large file,
-- read from the file. It may be less expensive to incrementally
-- hash the content provided by git, but Backend does not currently
-- have an interface to do so.
- Command.Smudge.clean' (toRawFilePath file)
+ Command.Smudge.clean' file
(parseLinkTargetOrPointer' b)
passthrough
discardreststdin
else Just True
}
-start :: FindOptions -> IsTerminal -> SeekInput -> RawFilePath -> Key -> CommandStart
+start :: FindOptions -> IsTerminal -> SeekInput -> OsPath -> Key -> CommandStart
start o isterminal _ file key = startingCustomOutput key $ do
- showFormatted isterminal (formatOption o) file
+ showFormatted isterminal (formatOption o) (fromOsPath file)
(formatVars key (AssociatedFile (Just file)))
next $ return True
formatVars :: Key -> AssociatedFile -> [(String, String)]
formatVars key (AssociatedFile af) =
- (maybe id (\f l -> (("file", fromRawFilePath f) : l)) af)
+ (maybe id (\f l -> (("file", fromOsPath f) : l)) af)
[ ("key", serializeKey key)
, ("backend", decodeBS $ formatKeyVariety $ fromKey keyVariety key)
, ("bytesize", size show)
, ("humansize", size $ roughSize storageUnits True)
, ("keyname", decodeBS $ S.fromShort $ fromKey keyName key)
- , ("hashdirlower", fromRawFilePath $ hashDirLower def key)
- , ("hashdirmixed", fromRawFilePath $ hashDirMixed def key)
+ , ("hashdirlower", fromOsPath $ hashDirLower def key)
+ , ("hashdirmixed", fromOsPath $ hashDirMixed def key)
, ("mtime", whenavail show $ fromKey keyMtime key)
]
where
data FixWhat = FixSymlinks | FixAll
-start :: FixWhat -> SeekInput -> RawFilePath -> Key -> CommandStart
+start :: FixWhat -> SeekInput -> OsPath -> Key -> CommandStart
start fixwhat si file key = do
- currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file
+ currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file'
wantlink <- calcRepo $ gitAnnexLink file key
case currlink of
Just l
- | l /= wantlink -> fixby $ fixSymlink file wantlink
+ | l /= fromOsPath wantlink ->
+ fixby $ fixSymlink file wantlink
| otherwise -> stop
Nothing -> case fixwhat of
FixAll -> fixthin
FixSymlinks -> stop
where
+ file' = fromOsPath file
fixby = starting "fix" (mkActionItem (key, file)) si
fixthin = do
obj <- calcRepo (gitAnnexLocation key)
stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do
thin <- annexThin <$> Annex.getGitConfig
- fs <- liftIO $ catchMaybeIO $ R.getFileStatus file
- os <- liftIO $ catchMaybeIO $ R.getFileStatus obj
+ fs <- liftIO $ catchMaybeIO $ R.getFileStatus file'
+ os <- liftIO $ catchMaybeIO $ R.getFileStatus (fromOsPath obj)
case (linkCount <$> fs, linkCount <$> os, thin) of
(Just 1, Just 1, True) ->
fixby $ makeHardLink file key
fixby $ breakHardLink file key obj
_ -> stop
-breakHardLink :: RawFilePath -> Key -> RawFilePath -> CommandPerform
+breakHardLink :: OsPath -> Key -> OsPath -> CommandPerform
breakHardLink file key obj = do
replaceWorkTreeFile file $ \tmp -> do
- mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
+ mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath file)
unlessM (checkedCopyFile key obj tmp mode) $
giveup "unable to break hard link"
thawContent tmp
modifyContentDir obj $ freezeContent obj
next $ return True
-makeHardLink :: RawFilePath -> Key -> CommandPerform
+makeHardLink :: OsPath -> Key -> CommandPerform
makeHardLink file key = do
replaceWorkTreeFile file $ \tmp -> do
- mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
+ mode <- liftIO $ catchMaybeIO $ fileMode
+ <$> R.getFileStatus (fromOsPath file)
linkFromAnnex' key tmp mode >>= \case
LinkAnnexFailed -> giveup "unable to make hard link"
_ -> noop
next $ return True
-fixSymlink :: RawFilePath -> RawFilePath -> CommandPerform
+fixSymlink :: OsPath -> OsPath -> CommandPerform
fixSymlink file link = do
#if ! defined(mingw32_HOST_OS)
-- preserve mtime of symlink
mtime <- liftIO $ catchMaybeIO $ Posix.modificationTimeHiRes
- <$> R.getSymbolicLinkStatus file
+ <$> R.getSymbolicLinkStatus (fromOsPath file)
#endif
replaceWorkTreeFile file $ \tmpfile -> do
- liftIO $ R.createSymbolicLink link tmpfile
+ let tmpfile' = fromOsPath tmpfile
+ liftIO $ R.createSymbolicLink link' tmpfile'
#if ! defined(mingw32_HOST_OS)
- liftIO $ maybe noop (\t -> touch tmpfile t False) mtime
+ liftIO $ maybe noop (\t -> touch tmpfile' t False) mtime
#endif
- stageSymlink file =<< hashSymlink link
+ stageSymlink file =<< hashSymlink link'
next $ return True
+ where
+ link' = fromOsPath link
let (keyname, file) = separate (== ' ') s
if not (null keyname) && not (null file)
then do
- file' <- liftIO $ relPathCwdToFile (toRawFilePath file)
+ file' <- liftIO $ relPathCwdToFile (toOsPath file)
return $ Right (file', keyOpt keyname)
else return $
Left "Expected pairs of key and filename"
inbackend <- inAnnex key
unless inbackend $ giveup $
"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)"
+ let file' = toOsPath file
let ai = mkActionItem (key, file')
starting "fromkey" ai si $
perform matcher key file'
- where
- file' = toRawFilePath file
-- From user input to a Key.
-- User can input either a serialized key, or an url.
Just k -> Right k
Nothing -> Left $ "bad key/url " ++ s
-perform :: AddUnlockedMatcher -> Key -> RawFilePath -> CommandPerform
+perform :: AddUnlockedMatcher -> Key -> OsPath -> CommandPerform
perform matcher key file = lookupKeyNotHidden file >>= \case
- Nothing -> ifM (liftIO $ doesFileExist (fromRawFilePath file))
+ Nothing -> ifM (liftIO $ doesFileExist file)
( hasothercontent
, do
contentpresent <- inAnnex key
else writepointer
, do
link <- calcRepo $ gitAnnexLink file key
- addAnnexLink link file
+ addAnnexLink (fromOsPath link) file
)
next $ return True
)
import qualified Data.Set as S
import qualified Data.Map as M
import Data.Either
-import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (fileMode, isSymbolicLink, modificationTime)
cmd :: Command
whenM ((==) DeadTrusted <$> lookupTrust u) $
earlyWarning "Warning: Fscking a repository that is currently marked as dead."
-start :: Maybe Remote -> Incremental -> SeekInput -> RawFilePath -> Key -> CommandStart
-start from inc si file key = Backend.getBackend (fromRawFilePath file) key >>= \case
+start :: Maybe Remote -> Incremental -> SeekInput -> OsPath -> Key -> CommandStart
+start from inc si file key = Backend.getBackend file key >>= \case
Nothing -> stop
Just backend -> do
(numcopies, _mincopies) <- getFileNumMinCopies file
go = runFsck inc si (mkActionItem (key, afile)) key
afile = AssociatedFile (Just file)
-perform :: Key -> RawFilePath -> Backend -> NumCopies -> Annex Bool
+perform :: Key -> OsPath -> Backend -> NumCopies -> Annex Bool
perform key file backend numcopies = do
keystatus <- getKeyFileStatus key file
check
pid <- liftIO getPID
t <- fromRepo gitAnnexTmpObjectDir
createAnnexDirectory t
- let tmp = t P.</> "fsck" <> toRawFilePath (show pid) <> "." <> keyFile key
- let cleanup = liftIO $ catchIO (R.removeLink tmp) (const noop)
+ let tmp = t </> literalOsPath "fsck" <> toOsPath (show pid) <> literalOsPath "." <> keyFile key
+ let cleanup = liftIO $ catchIO (removeFile tmp) (const noop)
cleanup
cleanup `after` a tmp
- getfile tmp = ifM (checkDiskSpace Nothing (Just (P.takeDirectory tmp)) key 0 True)
+ getfile tmp = ifM (checkDiskSpace Nothing (Just (takeDirectory tmp)) key 0 True)
( ifM (getcheap tmp)
( return (Just (Right UnVerified))
, ifM (Annex.getRead Annex.fast)
)
, return Nothing
)
- getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) (fromRawFilePath tmp) nullMeterUpdate (RemoteVerify remote)
+ getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) tmp nullMeterUpdate (RemoteVerify remote)
getcheap tmp = case Remote.retrieveKeyFileCheap remote of
- Just a -> isRight <$> tryNonAsync (a key afile (fromRawFilePath tmp))
+ Just a -> isRight <$> tryNonAsync (a key afile tmp)
Nothing -> return False
startKey :: Maybe Remote -> Incremental -> (SeekInput, Key, ActionItem) -> NumCopies -> CommandStart
check cs = and <$> sequence cs
{- Checks that symlinks points correctly to the annexed content. -}
-fixLink :: Key -> RawFilePath -> Annex Bool
+fixLink :: Key -> OsPath -> Annex Bool
fixLink key file = do
want <- calcRepo $ gitAnnexLink file key
- have <- getAnnexLinkTarget file
+ have <- fmap toOsPath <$> getAnnexLinkTarget file
maybe noop (go want) have
return True
where
| want /= fromInternalGitPath have = do
showNote "fixing link"
createWorkTreeDirectory (parentDir file)
- liftIO $ R.removeLink file
- addAnnexLink want file
+ liftIO $ R.removeLink (fromOsPath file)
+ addAnnexLink (fromOsPath want) file
| otherwise = noop
{- A repository that supports symlinks and is not bare may have in the past
idealloc <- calcRepo (gitAnnexLocation' (const (pure True)) key)
if loc == idealloc
then return True
- else ifM (liftIO $ R.doesPathExist loc)
+ else ifM (liftIO $ R.doesPathExist $ fromOsPath loc)
( moveobjdir loc idealloc
`catchNonAsync` \_e -> return True
, return True
-- Thaw the content directory to allow renaming it.
thawContentDir src
createAnnexDirectory (parentDir destdir)
- liftIO $ renameDirectory
- (fromRawFilePath srcdir)
- (fromRawFilePath destdir)
+ liftIO $ renameDirectory srcdir destdir
-- Since the directory was moved, lockContentForRemoval
-- will not be able to remove the lock file it
-- made. So, remove the lock file here.
mlockfile <- contentLockFile key =<< getVersion
- liftIO $ maybe noop (removeWhenExistsWith R.removeLink) mlockfile
+ liftIO $ maybe noop (removeWhenExistsWith removeFile) mlockfile
freezeContentDir dest
cleanObjectDirs src
return True
verifyLocationLog key keystatus ai = do
obj <- calcRepo (gitAnnexLocation key)
present <- if isKeyUnlockedThin keystatus
- then liftIO (doesFileExist (fromRawFilePath obj))
+ then liftIO (doesFileExist obj)
else inAnnex key
u <- getUUID
checkContentWritePerm obj >>= \case
Nothing -> warning $ "** Unable to set correct write mode for " <> QuotedPath obj <> " ; perhaps you don't own that file, or perhaps it has an xattr or ACL set"
_ -> return ()
- whenM (liftIO $ R.doesPathExist $ parentDir obj) $
+ whenM (liftIO $ doesDirectoryExist $ parentDir obj) $
freezeContentDir obj
{- Warn when annex.securehashesonly is set and content using an
verifyRequiredContent _ _ = return True
{- Verifies the associated file records. -}
-verifyAssociatedFiles :: Key -> KeyStatus -> RawFilePath -> Annex Bool
+verifyAssociatedFiles :: Key -> KeyStatus -> OsPath -> Annex Bool
verifyAssociatedFiles key keystatus file = do
when (isKeyUnlockedThin keystatus) $ do
f <- inRepo $ toTopFilePath file
Database.Keys.addAssociatedFile key f
return True
-verifyWorkTree :: Key -> RawFilePath -> Annex Bool
+verifyWorkTree :: Key -> OsPath -> Annex Bool
verifyWorkTree key file = do
{- Make sure that a pointer file is replaced with its content,
- when the content is available. -}
Just k | k == key -> whenM (inAnnex key) $ do
showNote "fixing worktree content"
replaceWorkTreeFile file $ \tmp -> do
- mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
+ mode <- liftIO $ catchMaybeIO $
+ fileMode <$> R.getFileStatus
+ (fromOsPath file)
ifM (annexThin <$> Annex.getGitConfig)
( void $ linkFromAnnex' key tmp mode
, do
checkKeySize _ KeyUnlockedThin _ = return True
checkKeySize key _ ai = do
file <- calcRepo $ gitAnnexLocation key
- ifM (liftIO $ R.doesPathExist file)
+ ifM (liftIO $ R.doesPathExist (fromOsPath file))
( checkKeySizeOr badContent key file ai
, return True
)
-withLocalCopy :: Maybe RawFilePath -> (RawFilePath -> Annex Bool) -> Annex Bool
+withLocalCopy :: Maybe OsPath -> (OsPath -> Annex Bool) -> Annex Bool
withLocalCopy Nothing _ = return True
withLocalCopy (Just localcopy) f = f localcopy
-checkKeySizeRemote :: Key -> Remote -> ActionItem -> RawFilePath -> Annex Bool
+checkKeySizeRemote :: Key -> Remote -> ActionItem -> OsPath -> Annex Bool
checkKeySizeRemote key remote ai localcopy =
checkKeySizeOr (badContentRemote remote localcopy) key localcopy ai
-checkKeySizeOr :: (Key -> Annex String) -> Key -> RawFilePath -> ActionItem -> Annex Bool
+checkKeySizeOr :: (Key -> Annex String) -> Key -> OsPath -> ActionItem -> Annex Bool
checkKeySizeOr bad key file ai = case fromKey keySize key of
Nothing -> return True
Just size -> do
checkBackend :: Key -> KeyStatus -> AssociatedFile -> Annex Bool
checkBackend key keystatus afile = do
content <- calcRepo (gitAnnexLocation key)
- ifM (liftIO $ R.doesPathExist content)
+ ifM (liftIO $ R.doesPathExist (fromOsPath content))
( ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content))
( nocheck
, do
ai = mkActionItem (key, afile)
-checkBackendRemote :: Key -> Remote -> ActionItem -> RawFilePath -> Annex Bool
+checkBackendRemote :: Key -> Remote -> ActionItem -> OsPath -> Annex Bool
checkBackendRemote key remote ai localcopy =
checkBackendOr (badContentRemote remote localcopy) key localcopy ai
-checkBackendOr :: (Key -> Annex String) -> Key -> RawFilePath -> ActionItem -> Annex Bool
+checkBackendOr :: (Key -> Annex String) -> Key -> OsPath -> ActionItem -> Annex Bool
checkBackendOr bad key file ai =
ifM (Annex.getRead Annex.fast)
( return True
- verified to be correct. The InodeCache is generated again to detect if
- the object file was changed while the content was being verified.
-}
-checkInodeCache :: Key -> RawFilePath -> Maybe InodeCache -> ActionItem -> Annex ()
+checkInodeCache :: Key -> OsPath -> Maybe InodeCache -> ActionItem -> Annex ()
checkInodeCache key content mic ai = case mic of
Nothing -> noop
Just ic -> do
checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool
checkKeyNumCopies key afile numcopies = do
let (desc, hasafile) = case afile of
- AssociatedFile Nothing -> (serializeKey' key, False)
+ AssociatedFile Nothing -> (toOsPath (serializeKey'' key), False)
AssociatedFile (Just af) -> (af, True)
locs <- loggedLocations key
(untrustedlocations, otherlocations) <- trustPartition UnTrusted locs
)
else return True
-missingNote :: RawFilePath -> Int -> NumCopies -> String -> String -> StringContainingQuotedPath
+missingNote :: OsPath -> Int -> NumCopies -> String -> String -> StringContainingQuotedPath
missingNote file 0 _ [] dead =
"** No known copies exist of " <> QuotedPath file <> UnquotedString (honorDead dead)
missingNote file 0 _ untrusted dead =
badContent :: Key -> Annex String
badContent key = do
dest <- moveBad key
- return $ "moved to " ++ fromRawFilePath dest
+ return $ "moved to " ++ fromOsPath dest
{- Bad content is dropped from the remote. We have downloaded a copy
- from the remote to a temp file already (in some cases, it's just a
- symlink to a file in the remote). To avoid any further data loss,
- that temp file is moved to the bad content directory unless
- the local annex has a copy of the content. -}
-badContentRemote :: Remote -> RawFilePath -> Key -> Annex String
+badContentRemote :: Remote -> OsPath -> Key -> Annex String
badContentRemote remote localcopy key = do
bad <- fromRepo gitAnnexBadDir
- let destbad = bad P.</> keyFile key
- let destbad' = fromRawFilePath destbad
- movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad'))
+ let destbad = bad </> keyFile key
+ movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad))
( return False
, do
createAnnexDirectory (parentDir destbad)
liftIO $ catchDefaultIO False $
- ifM (isSymbolicLink <$> R.getSymbolicLinkStatus localcopy)
- ( copyFileExternal CopyTimeStamps (fromRawFilePath localcopy) destbad'
+ ifM (isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath localcopy))
+ ( copyFileExternal CopyTimeStamps localcopy destbad
, do
moveFile localcopy destbad
return True
Remote.logStatus NoLiveUpdate remote key InfoMissing
return $ case (movedbad, dropped) of
(True, Right ()) -> "moved from " ++ Remote.name remote ++
- " to " ++ fromRawFilePath destbad
+ " to " ++ fromOsPath destbad
(False, Right ()) -> "dropped from " ++ Remote.name remote
(_, Left e) -> "failed to drop from" ++ Remote.name remote ++ ": " ++ show e
recordStartTime u = do
f <- fromRepo (gitAnnexFsckState u)
createAnnexDirectory $ parentDir f
- liftIO $ removeWhenExistsWith R.removeLink f
- liftIO $ F.withFile (toOsPath f) WriteMode $ \h -> do
+ liftIO $ removeWhenExistsWith removeFile f
+ liftIO $ F.withFile f WriteMode $ \h -> do
#ifndef mingw32_HOST_OS
- t <- modificationTime <$> R.getFileStatus f
+ t <- modificationTime <$> R.getFileStatus (fromOsPath f)
#else
t <- getPOSIXTime
#endif
showTime = show
resetStartTime :: UUID -> Annex ()
-resetStartTime u = liftIO . removeWhenExistsWith R.removeLink
+resetStartTime u = liftIO . removeWhenExistsWith removeFile
=<< fromRepo (gitAnnexFsckState u)
{- Gets the incremental fsck start time. -}
getStartTime u = do
f <- fromRepo (gitAnnexFsckState u)
liftIO $ catchDefaultIO Nothing $ do
- timestamp <- modificationTime <$> R.getFileStatus f
+ timestamp <- modificationTime <$> R.getFileStatus (fromOsPath f)
let fromstatus = Just (realToFrac timestamp)
- fromfile <- parsePOSIXTime <$> F.readFile' (toOsPath f)
+ fromfile <- parsePOSIXTime <$> F.readFile' f
return $ if matchingtimestamp fromfile fromstatus
then Just timestamp
else Nothing
toFilePath (FuzzDir d) = d
isFuzzFile :: FilePath -> Bool
-isFuzzFile f = "fuzzfile_" `isPrefixOf` takeFileName f
+isFuzzFile f = "fuzzfile_" `isPrefixOf` fromOsPath (takeFileName (toOsPath f))
isFuzzDir :: FilePath -> Bool
isFuzzDir d = "fuzzdir_" `isPrefixOf` d
mkFuzzFile :: FilePath -> [FuzzDir] -> FuzzFile
-mkFuzzFile file dirs = FuzzFile $ joinPath (map toFilePath dirs) </> ("fuzzfile_" ++ file)
+mkFuzzFile file dirs = FuzzFile $ fromOsPath $
+ joinPath (map (toOsPath . toFilePath) dirs) </> toOsPath ("fuzzfile_" ++ file)
mkFuzzDir :: Int -> FuzzDir
mkFuzzDir n = FuzzDir $ "fuzzdir_" ++ show n
runFuzzAction :: FuzzAction -> Annex ()
runFuzzAction (FuzzAdd (FuzzFile f)) = do
- createWorkTreeDirectory (parentDir (toRawFilePath f))
+ createWorkTreeDirectory (parentDir (toOsPath f))
n <- liftIO (getStdRandom random :: IO Int)
liftIO $ writeFile f $ show n ++ "\n"
runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $
- removeWhenExistsWith R.removeLink (toRawFilePath f)
+ removeWhenExistsWith removeFile (toOsPath f)
runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $
R.rename (toRawFilePath src) (toRawFilePath dest)
runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $
- removeDirectoryRecursive d
+ removeDirectoryRecursive (toOsPath d)
runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $
R.rename (toRawFilePath src) (toRawFilePath dest)
runFuzzAction (FuzzPause d) = randomDelay d
case md of
Nothing -> genFuzzAction
Just d -> do
- newd <- liftIO $ newDir (parentDir $ toRawFilePath $ toFilePath d)
+ newd <- liftIO $ newDir (parentDir $ toOsPath $ toFilePath d)
maybe genFuzzAction (return . FuzzMoveDir d) newd
FuzzDeleteDir _ -> do
d <- liftIO existingDir
existingFile 0 _ = return Nothing
existingFile n top = do
dir <- existingDirIncludingTop
- contents <- catchDefaultIO [] (getDirectoryContents dir)
+ contents <- map fromOsPath
+ <$> catchDefaultIO [] (getDirectoryContents (toOsPath dir))
let files = filter isFuzzFile contents
if null files
then do
then return Nothing
else do
i <- getStdRandom $ randomR (0, length dirs - 1)
- existingFile (n - 1) (top </> dirs !! i)
+ existingFile (n - 1) (fromOsPath (toOsPath top </> toOsPath (dirs !! i)))
else do
i <- getStdRandom $ randomR (0, length files - 1)
- return $ Just $ FuzzFile $ top </> dir </> files !! i
+ return $ Just $ FuzzFile $ fromOsPath $
+ toOsPath top </> toOsPath dir </> toOsPath (files !! i)
existingDirIncludingTop :: IO FilePath
existingDirIncludingTop = do
- dirs <- filter isFuzzDir <$> getDirectoryContents "."
+ dirs <- filter (isFuzzDir . fromOsPath)
+ <$> getDirectoryContents (literalOsPath ".")
if null dirs
then return "."
else do
n <- getStdRandom $ randomR (0, length dirs)
- return $ ("." : dirs) !! n
+ return $ fromOsPath $ (literalOsPath "." : dirs) !! n
existingDir :: IO (Maybe FuzzDir)
existingDir = do
go 0 = return Nothing
go n = do
f <- genFuzzFile
- ifM (doesnotexist (toFilePath f))
+ ifM (doesnotexist (toOsPath (toFilePath f)))
( return $ Just f
, go (n - 1)
)
-newDir :: RawFilePath -> IO (Maybe FuzzDir)
+newDir :: OsPath -> IO (Maybe FuzzDir)
newDir parent = go (100 :: Int)
where
go 0 = return Nothing
go n = do
(FuzzDir d) <- genFuzzDir
- ifM (doesnotexist (fromRawFilePath parent </> d))
+ ifM (doesnotexist (parent </> toOsPath d))
( return $ Just $ FuzzDir d
, go (n - 1)
)
-doesnotexist :: FilePath -> IO Bool
-doesnotexist f = isNothing <$> catchMaybeIO (R.getSymbolicLinkStatus (toRawFilePath f))
+doesnotexist :: OsPath -> IO Bool
+doesnotexist f = isNothing <$> catchMaybeIO (R.getSymbolicLinkStatus (fromOsPath f))
where
ww = WarnUnmatchLsFiles "get"
-start :: GetOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart
+start :: GetOptions -> Maybe Remote -> SeekInput -> OsPath -> Key -> CommandStart
start o from si file key = do
lu <- prepareLiveUpdate Nothing key AddingKey
start' lu (expensivecheck lu) from key afile ai si
seek o@(LocalImportOptions {}) = startConcurrency commandStages $ do
repopath <- liftIO . absPath =<< fromRepo Git.repoPath
inrepops <- liftIO $ filter (dirContains repopath)
- <$> mapM (absPath . toRawFilePath) (importFiles o)
+ <$> mapM (absPath . toOsPath) (importFiles o)
unless (null inrepops) $ do
qp <- coreQuotePath <$> Annex.getGitConfig
giveup $ decodeBS $ quote qp $
giveup "That remote does not support imports."
subdir <- maybe
(pure Nothing)
- (Just <$$> inRepo . toTopFilePath . toRawFilePath)
+ (Just <$$> inRepo . toTopFilePath . toOsPath)
(importToSubDir o)
addunlockedmatcher <- addUnlockedMatcher
seekRemote r (importToBranch o) subdir (importContent o)
addunlockedmatcher
(messageOption o)
-startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (RawFilePath, RawFilePath) -> CommandStart
+startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (OsPath, OsPath) -> CommandStart
startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
- ifM (liftIO $ isRegularFile <$> R.getSymbolicLinkStatus srcfile)
+ ifM (liftIO $ isRegularFile <$> R.getSymbolicLinkStatus (fromOsPath srcfile))
( starting "import" ai si pickaction
, stop
)
showNote $ UnquotedString $ "duplicate of " ++ serializeKey k
verifyExisting k destfile
( do
- liftIO $ R.removeLink srcfile
+ liftIO $ removeFile srcfile
next $ return True
, do
warning "Could not verify that the content is still present in the annex; not removing from the import location."
warning $ "not importing " <> QuotedPath destfile <> " which is .gitignored (use --no-check-gitignore to override)"
stop
else do
- existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destfile)
+ existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath destfile))
case existing of
Nothing -> importfilechecked ld k
Just s
| isDirectory s -> notoverwriting "(is a directory)"
| isSymbolicLink s -> ifM (Annex.getRead Annex.force)
( do
- liftIO $ removeWhenExistsWith R.removeLink destfile
+ liftIO $ removeWhenExistsWith removeFile destfile
importfilechecked ld k
, notoverwriting "(is a symlink)"
)
| otherwise -> ifM (Annex.getRead Annex.force)
( do
- liftIO $ removeWhenExistsWith R.removeLink destfile
+ liftIO $ removeWhenExistsWith removeFile destfile
importfilechecked ld k
, notoverwriting "(use --force to override, or a duplication option such as --deduplicate to clean up)"
)
checkdestdir cont = do
let destdir = parentDir destfile
- existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destdir)
+ existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath destdir))
case existing of
Nothing -> cont
Just s
createWorkTreeDirectory (parentDir destfile)
unwind <- liftIO $ if mode == Duplicate || mode == SkipDuplicates
then do
- void $ copyFileExternal CopyAllMetaData
- (fromRawFilePath srcfile)
- (fromRawFilePath destfile)
- return $ removeWhenExistsWith R.removeLink destfile
+ void $ copyFileExternal CopyAllMetaData srcfile destfile
+ return $ removeWhenExistsWith removeFile destfile
else do
moveFile srcfile destfile
return $ moveFile destfile srcfile
-- weakly the same as the originally locked down file's
-- inode cache. (Since the file may have been copied,
-- its inodes may not be the same.)
- s <- liftIO $ R.getSymbolicLinkStatus destfile
+ s <- liftIO $ R.getSymbolicLinkStatus (fromOsPath destfile)
newcache <- withTSDelta $ \d -> liftIO $ toInodeCache d destfile s
let unchanged = case (newcache, inodeCache (keySource ld)) of
(_, Nothing) -> True
-- the file gets copied into the repository.
, checkWritePerms = False
}
- v <- lockDown cfg (fromRawFilePath srcfile)
+ v <- lockDown cfg srcfile
case v of
Just ld -> do
backend <- chooseBackend destfile
showNote (s <> "; skipping")
next (return True)
-verifyExisting :: Key -> RawFilePath -> (CommandPerform, CommandPerform) -> CommandPerform
+verifyExisting :: Key -> OsPath -> (CommandPerform, CommandPerform) -> CommandPerform
verifyExisting key destfile (yes, no) = do
-- Look up the numcopies setting for the file that it would be
-- imported to, if it were imported.
import Control.Concurrent.STM
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
-import qualified System.FilePath.ByteString as P
import qualified Data.ByteString as B
import Command
| scrapeOption o = scrape
| otherwise = get
- get = withTmpFile (toOsPath "feed") $ \tmpf h -> do
+ get = withTmpFile (literalOsPath "feed") $ \tmpf h -> do
let tmpf' = fromRawFilePath $ fromOsPath tmpf
liftIO $ hClose h
ifM (downloadFeed url tmpf')
downloadFeed url f
| Url.parseURIRelaxed url == Nothing = giveup "invalid feed url"
| otherwise = Url.withUrlOptions $
- Url.download nullMeterUpdate Nothing url f
+ Url.download nullMeterUpdate Nothing url (toOsPath f)
startDownload :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> TMVar Bool -> ToDownload -> CommandStart
startDownload addunlockedmatcher opts cache cv todownload = case location todownload of
ifM (useYoutubeDl (downloadOptions opts) <&&> youtubeDlSupported linkurl)
( startUrlDownload cv todownload linkurl $
withTmpWorkDir mediakey $ \workdir -> do
- dl <- youtubeDl linkurl (fromRawFilePath workdir) nullMeterUpdate
+ dl <- youtubeDl linkurl workdir nullMeterUpdate
case dl of
Right (Just mediafile) -> do
- let ext = case takeExtension mediafile of
+ let ext = case fromOsPath (takeExtension mediafile) of
[] -> ".m"
s -> s
runDownload todownload linkurl ext cache cv $ \f ->
checkCanAdd (downloadOptions opts) f $ \canadd -> do
- addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just (toRawFilePath mediafile))
+ addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just mediafile)
return (Just [mediakey])
-- youtube-dl didn't support it, so
-- download it as if the link were
)
downloadEnclosure :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> TMVar Bool -> ToDownload -> URLString -> CommandPerform
-downloadEnclosure addunlockedmatcher opts cache cv todownload url =
- runDownload todownload url (takeWhile (/= '?') $ takeExtension url) cache cv $ \f -> do
- let f' = fromRawFilePath f
+downloadEnclosure addunlockedmatcher opts cache cv todownload url =
+ let extension = takeWhile (/= '?') $ fromOsPath $ takeExtension $ toOsPath url
+ in runDownload todownload url extension cache cv $ \f -> do
r <- checkClaimingUrl (downloadOptions opts) url
if Remote.uuid r == webUUID || rawOption (downloadOptions opts)
then checkRaw (Just url) (downloadOptions opts) (pure Nothing) $ do
let dlopts = (downloadOptions opts)
-- force using the filename
-- chosen here
- { fileOption = Just f'
+ { fileOption = Just (fromOsPath f)
-- don't use youtube-dl
, rawOption = True
}
downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url f sz
Right (UrlMulti l) -> do
kl <- forM l $ \(url', sz, subf) ->
- let dest = f P.</> toRawFilePath (sanitizeFilePath subf)
+ let dest = f </> toOsPath (sanitizeFilePath (fromOsPath subf))
in downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url' dest sz
return $ Just $ if all isJust kl
then catMaybes kl
-> String
-> Cache
-> TMVar Bool
- -> (RawFilePath -> Annex (Maybe [Key]))
+ -> (OsPath -> Annex (Maybe [Key]))
-> CommandPerform
runDownload todownload url extension cache cv getter = do
dest <- makeunique (1 :: Integer) $
Nothing -> do
recordsuccess
next $ return True
- Just f -> getter (toRawFilePath f) >>= \case
+ Just f -> getter f >>= \case
Just ks
-- Download problem.
| null ks -> do
- to be re-downloaded. -}
makeunique n file = ifM alreadyexists
( ifM forced
- ( lookupKey (toRawFilePath f) >>= \case
+ ( lookupKey f >>= \case
Just k -> checksameurl k
Nothing -> tryanother
, tryanother
)
where
f = if n < 2
- then file
+ then toOsPath file
else
- let (d, base) = splitFileName file
- in d </> show n ++ "_" ++ base
+ let (d, base) = splitFileName (toOsPath file)
+ in d </> toOsPath (show n ++ "_") <> base
tryanother = makeunique (n + 1) file
- alreadyexists = liftIO $ isJust <$> catchMaybeIO (R.getSymbolicLinkStatus (toRawFilePath f))
+ alreadyexists = liftIO $ isJust <$> catchMaybeIO (R.getSymbolicLinkStatus (fromOsPath f))
checksameurl k = ifM (elem url . map fst . map getDownloader <$> getUrls k)
( return Nothing
, tryanother
- least 23 hours. -}
checkFeedBroken :: URLString -> Annex Bool
checkFeedBroken url = checkFeedBroken' url =<< feedState url
-checkFeedBroken' :: URLString -> RawFilePath -> Annex Bool
+checkFeedBroken' :: URLString -> OsPath -> Annex Bool
checkFeedBroken' url f = do
prev <- maybe Nothing readish
- <$> liftIO (catchMaybeIO $ readFile (fromRawFilePath f))
+ <$> liftIO (catchMaybeIO $ readFile (fromOsPath f))
now <- liftIO getCurrentTime
case prev of
Nothing -> do
clearFeedProblem :: URLString -> Annex ()
clearFeedProblem url =
- void $ liftIO . tryIO . removeFile . fromRawFilePath
- =<< feedState url
+ void $ liftIO . tryIO . removeFile =<< feedState url
-feedState :: URLString -> Annex RawFilePath
+feedState :: URLString -> Annex OsPath
feedState url = fromRepo $ gitAnnexFeedState $ fromUrl url Nothing False
{- The feed library parses the feed to Text, and does not use the
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Vector as V
-import qualified System.FilePath.ByteString as P
+import Data.ByteString.Short (fromShort)
import System.PosixCompat.Files (isDirectory)
import Data.Ord
import qualified Data.Semigroup as Sem
Right r -> remoteInfo o r si
Left _ -> Remote.nameToUUID' p >>= \case
([], _) -> do
- relp <- liftIO $ relPathCwdToFile (toRawFilePath p)
+ relp <- liftIO $ relPathCwdToFile (toOsPath p)
lookupKey relp >>= \case
- Just k -> fileInfo o (fromRawFilePath relp) si k
+ Just k -> fileInfo o (fromOsPath relp) si k
Nothing -> treeishInfo o p si
([u], _) -> uuidInfo o u si
(_us, msg) -> noInfo p si msg
-- The string may not really be a file, but use ActionItemTreeFile,
-- rather than ActionItemOther to avoid breaking back-compat of
-- json output.
- let ai = ActionItemTreeFile (toRawFilePath s)
+ let ai = ActionItemTreeFile (toOsPath s)
showStartMessage (StartMessage "info" ai si)
showNote (UnquotedString msg)
showEndFail
fileInfo :: InfoOptions -> FilePath -> SeekInput -> Key -> Annex ()
fileInfo o file si k = do
matcher <- Limit.getMatcher
- let file' = toRawFilePath file
+ let file' = toOsPath file
whenM (matcher $ MatchingFile $ FileInfo file' file' (Just k)) $
showCustom (unwords ["info", file]) si $ do
evalStateT (mapM_ showStat (file_stats file k)) (emptyStatInfo o)
where
desc = "transfers in progress"
line qp uuidmap t i = unwords
- [ fromRawFilePath (formatDirection (transferDirection t)) ++ "ing"
- , fromRawFilePath $ quote qp $ actionItemDesc $ mkActionItem
+ [ decodeBS $ fromShort (formatDirection (transferDirection t)) <> "ing"
+ , decodeBS $ quote qp $ actionItemDesc $ mkActionItem
(transferKey t, associatedFile i)
, if transferDirection t == Upload then "to" else "from"
, maybe (fromUUID $ transferUUID t) Remote.name $
M.lookup (transferUUID t) uuidmap
]
jsonify t i = object $ map (\(k, v) -> (textKey (packString k), v)) $
- [ ("transfer", toJSON' (formatDirection (transferDirection t)))
+ [ ("transfer", toJSON' (fromShort (formatDirection (transferDirection t))))
, ("key", toJSON' (transferKey t))
- , ("file", toJSON' (fromRawFilePath <$> afile))
+ , ("file", toJSON' ((fromOsPath <$> afile) :: Maybe FilePath))
, ("remote", toJSON' (fromUUID (transferUUID t) :: String))
]
where
disk_size = simpleStat "available local disk space" $
calcfree
<$> (lift $ annexDiskReserve <$> Annex.getGitConfig)
- <*> (lift $ inRepo $ getDiskFree . fromRawFilePath . gitAnnexDir)
+ <*> (lift $ inRepo $ getDiskFree . fromOsPath . gitAnnexDir)
<*> mkSizer
where
calcfree reserve (Just have) sizer = unwords
fast <- Annex.getRead Annex.fast
matcher <- Limit.getMatcher
(presentdata, referenceddata, numcopiesstats, repodata) <-
- Command.Unused.withKeysFilesReferencedIn dir initial
+ Command.Unused.withKeysFilesReferencedIn (toOsPath dir) initial
(update matcher fast)
return $ StatInfo
(Just presentdata)
M.fromList $ zip locs (map update locs)
update loc = addKey key (fromMaybe emptyKeyInfo $ M.lookup loc m)
-updateNumCopiesStats :: RawFilePath -> NumCopiesStats -> [UUID] -> Annex NumCopiesStats
+updateNumCopiesStats :: OsPath -> NumCopiesStats -> [UUID] -> Annex NumCopiesStats
updateNumCopiesStats file (NumCopiesStats m) locs = do
have <- trustExclude UnTrusted locs
!variance <- Variance <$> numCopiesCheck' file (-) have
"+ " ++ show (unknownSizeKeys d) ++
" unknown size"
-staleSize :: String -> (Git.Repo -> RawFilePath) -> Stat
+staleSize :: String -> (Git.Repo -> OsPath) -> Stat
staleSize label dirspec = go =<< lift (dirKeys dirspec)
where
go [] = nostat
keysizes keys = do
dir <- lift $ fromRepo dirspec
liftIO $ forM keys $ \k ->
- catchDefaultIO 0 $ getFileSize (dir P.</> keyFile k)
+ catchDefaultIO 0 $ getFileSize (dir </> keyFile k)
aside :: String -> String
aside s = " (" ++ s ++ ")"
where
ww = WarnUnmatchLsFiles "inprogress"
-start :: IsTerminal -> S.Set Key -> SeekInput -> RawFilePath -> Key -> CommandStart
+start :: IsTerminal -> S.Set Key -> SeekInput -> OsPath -> Key -> CommandStart
start isterminal s _si _file k
| S.member k s = start' isterminal k
| otherwise = stop
start' :: IsTerminal -> Key -> CommandStart
start' (IsTerminal isterminal) k = startingCustomOutput k $ do
- tmpf <- fromRawFilePath <$> fromRepo (gitAnnexTmpObjectLocation k)
+ tmpf <- fromRepo (gitAnnexTmpObjectLocation k)
whenM (liftIO $ doesFileExist tmpf) $
- liftIO $ putStrLn (if isterminal then safeOutput tmpf else tmpf)
+ liftIO $ putStrLn $
+ if isterminal
+ then safeOutput (fromOsPath tmpf)
+ else fromOsPath tmpf
next $ return True
printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex ()
printHeader l = liftIO $ putStrLn $ safeOutput $ lheader $ map (\(_, n, t) -> (n, t)) l
-start :: [(UUID, RemoteName, TrustLevel)] -> SeekInput -> RawFilePath -> Key -> CommandStart
+start :: [(UUID, RemoteName, TrustLevel)] -> SeekInput -> OsPath -> Key -> CommandStart
start l _si file key = do
ls <- S.fromList <$> keyLocations key
qp <- coreQuotePath <$> Annex.getGitConfig
trust UnTrusted = " (untrusted)"
trust _ = ""
-format :: [(TrustLevel, Present)] -> RawFilePath -> StringContainingQuotedPath
+format :: [(TrustLevel, Present)] -> OsPath -> StringContainingQuotedPath
format remotes file = UnquotedString (thereMap) <> " " <> QuotedPath file
where
thereMap = concatMap there remotes
, usesLocationLog = False
}
-start :: SeekInput -> RawFilePath -> Key -> CommandStart
+start :: SeekInput -> OsPath -> Key -> CommandStart
start si file key = ifM (isJust <$> isAnnexLink file)
( stop
, starting "lock" (mkActionItem (key, file)) si $
)
cont = perform file key
-perform :: RawFilePath -> Key -> CommandPerform
+perform :: OsPath -> Key -> CommandPerform
perform file key = do
lockdown =<< calcRepo (gitAnnexLocation key)
addSymlink file key =<< withTSDelta (liftIO . genInodeCache file)
( breakhardlink obj
, repopulate obj
)
- whenM (liftIO $ R.doesPathExist obj) $
+ whenM (liftIO $ doesFileExist obj) $
freezeContent obj
+ getlinkcount obj = linkCount <$> liftIO (R.getFileStatus (fromOsPath obj))
+
-- It's ok if the file is hard linked to obj, but if some other
-- associated file is, we need to break that link to lock down obj.
- breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (R.getFileStatus obj)) $ do
+ breakhardlink obj = whenM (catchBoolIO $ (> 1) <$> getlinkcount obj) $ do
mfc <- withTSDelta (liftIO . genInodeCache file)
unlessM (sameInodeCache obj (maybeToList mfc)) $ do
modifyContentDir obj $ replaceGitAnnexDirFile obj $ \tmp -> do
fs <- map (`fromTopFilePath` g)
<$> Database.Keys.getAssociatedFiles key
mfile <- firstM (isUnmodified key) fs
- liftIO $ removeWhenExistsWith R.removeLink obj
+ liftIO $ removeWhenExistsWith removeFile obj
case mfile of
Just unmodified ->
ifM (checkedCopyFile key unmodified obj Nothing)
import Data.Time.Clock.POSIX
import Data.Time
import qualified Data.ByteString.Char8 as B8
-import qualified System.FilePath.ByteString as P
import Control.Concurrent.Async
import Command
import Types.TrustLevel
import Utility.DataUnits
import Utility.HumanTime
+import qualified Utility.FileIO as F
data LogChange = Added | Removed
top <- fromRepo Git.repoPath
p <- liftIO $ relPathCwdToFile top
config <- Annex.getGitConfig
- let logfile = p P.</> locationLogFile config key
- getGitLogAnnex [fromRawFilePath logfile] (Param "--remove-empty" : os)
+ let logfile = p </> locationLogFile config key
+ getGitLogAnnex [logfile] (Param "--remove-empty" : os)
-getGitLogAnnex :: [FilePath] -> [CommandParam] -> Annex ([LoggedFileChange Key], IO Bool)
+getGitLogAnnex :: [OsPath] -> [CommandParam] -> Annex ([LoggedFileChange Key], IO Bool)
getGitLogAnnex fs os = do
config <- Annex.getGitConfig
let fileselector = \_sha f ->
- locationLogFileKey config (toRawFilePath f)
- inRepo $ getGitLog Annex.Branch.fullname Nothing fs os fileselector
+ locationLogFileKey config f
+ inRepo $ getGitLog Annex.Branch.fullname Nothing (map fromOsPath fs) os fileselector
showTimeStamp :: TimeZone -> String -> POSIXTime -> String
showTimeStamp zone format = formatTime defaultTimeLocale format
-- and to the trust log.
getlog = do
config <- Annex.getGitConfig
- let fileselector = \_sha f -> let f' = toRawFilePath f in
- case locationLogFileKey config f' of
+ let fileselector = \_sha f ->
+ case locationLogFileKey config f of
Just k -> Just (Right k)
Nothing
- | f' == trustLog -> Just (Left ())
+ | f == trustLog -> Just (Left ())
| otherwise -> Nothing
inRepo $ getGitLog Annex.Branch.fullname Nothing []
[ Param "--date-order"
displaystart uuidmap zone
| gnuplotOption o = do
file <- (</>)
- <$> fromRepo (fromRawFilePath . gitAnnexDir)
- <*> pure "gnuplot"
- liftIO $ putStrLn $ "Generating gnuplot script in " ++ file
- h <- liftIO $ openFile file WriteMode
+ <$> fromRepo gitAnnexDir
+ <*> pure (literalOsPath "gnuplot")
+ liftIO $ putStrLn $ "Generating gnuplot script in " ++ fromOsPath file
+ h <- liftIO $ F.openFile file WriteMode
liftIO $ mapM_ (hPutStrLn h)
[ "set datafile separator ','"
, "set timefmt \"%Y-%m-%dT%H:%M:%S\""
hFlush h
putStrLn $ "Running gnuplot..."
void $ liftIO $ boolSystem "gnuplot"
- [Param "-p", File file]
+ [Param "-p", File (fromOsPath file)]
return (dispst h endaction)
| sizesOption o = do
liftIO $ putStrLn uuidmapheader
| refOption o = catKey (Ref (toRawFilePath file)) >>= display
| otherwise = do
checkNotBareRepo
- seekSingleGitFile file >>= \case
+ seekSingleGitFile (toOsPath file) >>= \case
Nothing -> return False
Just file' -> catKeyFile file' >>= display
-- To support absolute filenames, pass through git ls-files.
-- But, this plumbing command does not recurse through directories.
-seekSingleGitFile :: FilePath -> Annex (Maybe RawFilePath)
+seekSingleGitFile :: OsPath -> Annex (Maybe OsPath)
seekSingleGitFile file
- | isRelative file = return (Just (toRawFilePath file))
+ | isRelative file = return (Just file)
| otherwise = do
- (l, cleanup) <- inRepo (Git.LsFiles.inRepo [] [toRawFilePath file])
+ (l, cleanup) <- inRepo (Git.LsFiles.inRepo [] [file])
r <- case l of
- (f:[]) | takeFileName (fromRawFilePath f) == takeFileName file ->
+ (f:[]) | takeFileName f == takeFileName file ->
return (Just f)
_ -> return Nothing
void $ liftIO cleanup
trustmap <- trustMapLoad
file <- (</>)
- <$> fromRepo (fromRawFilePath . gitAnnexDir)
- <*> pure "map.dot"
+ <$> fromRepo gitAnnexDir
+ <*> pure (literalOsPath "map.dot")
- liftIO $ writeFile file (drawMap rs trustmap umap)
+ liftIO $ writeFile (fromOsPath file) (drawMap rs trustmap umap)
next $
ifM (Annex.getRead Annex.fast)
( runViewer file []
, runViewer file
- [ ("xdot", [File file])
- , ("dot", [Param "-Tx11", File file])
+ [ ("xdot", [File (fromOsPath file)])
+ , ("dot", [Param "-Tx11", File (fromOsPath file)])
]
)
-runViewer :: FilePath -> [(String, [CommandParam])] -> Annex Bool
+runViewer :: OsPath -> [(String, [CommandParam])] -> Annex Bool
runViewer file [] = do
- showLongNote $ UnquotedString $ "left map in " ++ file
+ showLongNote $ UnquotedString $ "left map in " ++ fromOsPath file
return True
runViewer file ((c, ps):rest) = ifM (liftIO $ inSearchPath c)
( do
where
remotecmd = "sh -c " ++ shellEscape
(cddir ++ " && " ++ "git config --null --list")
- dir = fromRawFilePath $ Git.repoPath r
+ dir = fromOsPath $ Git.repoPath r
cddir
| "/~" `isPrefixOf` dir =
let (userhome, reldir) = span (/= '/') (drop 1 dir)
<*> (MatchingUserInfo . addkeysize <$> dataparser)
where
dataparser = UserProvidedInfo
- <$> optinfo "file" (strOption
+ <$> optinfo "file" ((fmap stringToOsPath . strOption)
( long "file" <> metavar paramFile
<> help "specify filename to match against"
))
)
_ -> giveup "--batch is currently only supported in --json mode"
-start :: CandidateVectorClock -> MetaDataOptions -> SeekInput -> RawFilePath -> Key -> CommandStart
+start :: CandidateVectorClock -> MetaDataOptions -> SeekInput -> OsPath -> Key -> CommandStart
start c o si file k = startKeys c o (si, k, mkActionItem (k, afile))
where
afile = AssociatedFile (Just file)
unwrapmeta (f, v) = (fromMetaField f, map fromMetaValue (S.toList v))
showmeta (f, vs) = map ((T.unpack f ++ "=") ++) (map decodeBS vs)
-parseJSONInput :: String -> Annex (Either String (Either RawFilePath Key, MetaData))
+parseJSONInput :: String -> Annex (Either String (Either OsPath Key, MetaData))
parseJSONInput i = case eitherDecode (BU.fromString i) of
Left e -> return (Left e)
Right v -> do
(Just k, _) -> return $
Right (Right k, m)
(Nothing, Just f) -> do
- f' <- liftIO $ relPathCwdToFile (toRawFilePath f)
+ f' <- liftIO $ relPathCwdToFile f
return $ Right (Left f', m)
(Nothing, Nothing) -> return $
Left "JSON input is missing either file or key"
-startBatch :: (SeekInput, (Either RawFilePath Key, MetaData)) -> CommandStart
+startBatch :: (SeekInput, (Either OsPath Key, MetaData)) -> CommandStart
startBatch (si, (i, (MetaData m))) = case i of
Left f -> do
mk <- lookupKeyStaged f
-- by multiple jobs.
void $ includeCommandAction $ update oldkey newkey
-start :: MigrateOptions -> Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart
+start :: MigrateOptions -> Maybe KeySha -> SeekInput -> OsPath -> Key -> CommandStart
start o ksha si file key = do
forced <- Annex.getRead Annex.force
- v <- Backend.getBackend (fromRawFilePath file) key
+ v <- Backend.getBackend file key
case v of
Nothing -> stop
Just oldbackend -> do
- data cannot get corrupted after the fsck but before the new key is
- generated.
-}
-perform :: Bool -> MigrateOptions -> RawFilePath -> Key -> MigrationRecord -> Backend -> Backend -> CommandPerform
+perform :: Bool -> MigrateOptions -> OsPath -> Key -> MigrationRecord -> Backend -> Backend -> CommandPerform
perform onlytweaksize o file oldkey oldkeyrec oldbackend newbackend = go =<< genkey (fastMigrate oldbackend)
where
go Nothing = stop
, usesLocationLog = True
}
-start :: MirrorOptions -> SeekInput -> RawFilePath -> Key -> CommandStart
+start :: MirrorOptions -> SeekInput -> OsPath -> Key -> CommandStart
start o si file k = startKey o afile (si, k, ai)
where
afile = AssociatedFile (Just file)
stages (FromRemoteToRemote _ _) = transferStages
stages (FromAnywhereToRemote _) = transferStages
-start :: LiveUpdate -> FromToHereOptions -> RemoveWhen -> SeekInput -> RawFilePath -> Key -> CommandStart
+start :: LiveUpdate -> FromToHereOptions -> RemoveWhen -> SeekInput -> OsPath -> Key -> CommandStart
start lu fromto removewhen si f k = start' lu fromto removewhen afile si k ai
where
afile = AssociatedFile (Just f)
import Utility.Tmp
import Utility.Tmp.Dir
import Utility.Process.Transcript
-import qualified Utility.RawFilePath as R
import Data.Char
import qualified Data.ByteString.Lazy.UTF8 as B8
(s, ok) <- case k of
KeyContainer s -> liftIO $ genkey (Param s)
KeyFile f -> do
- createAnnexDirectory (toRawFilePath (takeDirectory f))
- liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
- liftIO $ protectedOutput $ genkey (File f)
+ createAnnexDirectory (takeDirectory f)
+ liftIO $ removeWhenExistsWith removeFile f
+ liftIO $ protectedOutput $ genkey (File (fromOsPath f))
case (ok, parseFingerprint s) of
(False, _) -> giveup $ "uftp_keymgt failed: " ++ s
(_, Nothing) -> giveup $ "Failed to find fingerprint in uftp_keymgt output: " ++ s
-- the names of keys, and would have to be copied, which is too
-- expensive.
starting "sending files" (ActionItemOther Nothing) (SeekInput []) $
- withTmpFile (toOsPath "send") $ \t h -> do
+ withTmpFile (literalOsPath "send") $ \t h -> do
let ww = WarnUnmatchLsFiles "multicast"
(fs', cleanup) <- seekHelper id ww LsFiles.inRepo
=<< workTreeItems ww fs
matcher <- Limit.getMatcher
let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f Nothing) $
- liftIO $ hPutStrLn h o
+ liftIO $ hPutStrLn h (fromOsPath o)
forM_ fs' $ \(_, f) -> do
mk <- lookupKey f
case mk of
Nothing -> noop
- Just k -> withObjectLoc k $
- addlist f . fromRawFilePath
+ Just k -> withObjectLoc k $ addlist f
liftIO $ hClose h
liftIO $ void cleanup
, Param "-k", uftpKeyParam serverkey
, Param "-U", Param (uftpUID u)
-- only allow clients on the authlist
- , Param "-H", Param ("@"++authlist)
+ , Param "-H", Param ("@"++fromOsPath authlist)
-- pass in list of files to send
- , Param "-i", File (fromRawFilePath (fromOsPath t))
+ , Param "-i", File (fromOsPath t)
] ++ ups
liftIO (boolSystem "uftp" ps) >>= showEndResult
next $ return True
(callback, environ, statush) <- liftIO multicastCallbackEnv
tmpobjdir <- fromRepo gitAnnexTmpObjectDir
createAnnexDirectory tmpobjdir
- withTmpDirIn (fromRawFilePath tmpobjdir) (toOsPath "multicast") $ \tmpdir -> withAuthList $ \authlist -> do
- abstmpdir <- liftIO $ absPath (toRawFilePath tmpdir)
- abscallback <- liftIO $ searchPath callback
+ withTmpDirIn tmpobjdir (literalOsPath "multicast") $ \tmpdir -> withAuthList $ \authlist -> do
+ abstmpdir <- liftIO $ absPath tmpdir
+ abscallback <- liftIO $ searchPath (fromOsPath callback)
let ps =
-- Avoid it running as a daemon.
[ Param "-d"
, Param "-k", uftpKeyParam clientkey
, Param "-U", Param (uftpUID u)
-- Only allow servers on the authlist
- , Param "-S", Param authlist
+ , Param "-S", Param (fromOsPath authlist)
-- Receive files into tmpdir
-- (it needs an absolute path)
- , Param "-D", File (fromRawFilePath abstmpdir)
+ , Param "-D", File (fromOsPath abstmpdir)
-- Run callback after each file received
-- (it needs an absolute path)
- , Param "-s", Param (fromMaybe callback abscallback)
+ , Param "-s", Param (fromOsPath $ fromMaybe callback abscallback)
] ++ ups
runner <- liftIO $ async $
hClose statush
`after` boolSystemEnv "uftpd" ps (Just environ)
- mapM_ storeReceived . lines =<< liftIO (hGetContents statush)
+ mapM_ storeReceived . map toOsPath . lines
+ =<< liftIO (hGetContents statush)
showEndResult =<< liftIO (wait runner)
next $ return True
where
ai = ActionItemOther Nothing
si = SeekInput []
-storeReceived :: FilePath -> Annex ()
+storeReceived :: OsPath -> Annex ()
storeReceived f = do
- case deserializeKey (takeFileName f) of
+ case deserializeKey' (fromOsPath (takeFileName f)) of
Nothing -> do
- warning $ "Received a file " <> QuotedPath (toRawFilePath f) <> " that is not a git-annex key. Deleting this file."
- liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
+ warning $ "Received a file " <> QuotedPath f <> " that is not a git-annex key. Deleting this file."
+ liftIO $ removeWhenExistsWith removeFile f
Just k -> void $ logStatusAfter NoLiveUpdate k $
getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $
liftIO $ catchBoolIO $ do
- R.rename (toRawFilePath f) dest
+ renameFile f dest
return True
-- Under Windows, uftp uses key containers, which are not files on the
-- filesystem.
-data UftpKey = KeyFile FilePath | KeyContainer String
+data UftpKey = KeyFile OsPath | KeyContainer String
uftpKeyParam :: UftpKey -> CommandParam
-uftpKeyParam (KeyFile f) = File f
+uftpKeyParam (KeyFile f) = File (fromOsPath f)
uftpKeyParam (KeyContainer s) = Param s
uftpKey :: Annex UftpKey
u <- getUUID
return $ KeyContainer $ "annex-" ++ fromUUID u
#else
-uftpKey = KeyFile <$> credsFile "multicast"
+uftpKey = KeyFile <$> credsFile (literalOsPath "multicast")
#endif
-- uftp needs a unique UID for each client and server, which
uftpUID :: UUID -> String
uftpUID u = "0x" ++ (take 8 $ show $ sha2_256 $ B8.fromString (fromUUID u))
-withAuthList :: (FilePath -> Annex a) -> Annex a
+withAuthList :: (OsPath -> Annex a) -> Annex a
withAuthList a = do
m <- knownFingerPrints
- withTmpFile (toOsPath "authlist") $ \t h -> do
+ withTmpFile (literalOsPath "authlist") $ \t h -> do
liftIO $ hPutStr h (genAuthList m)
liftIO $ hClose h
- a (fromRawFilePath (fromOsPath t))
+ a t
genAuthList :: M.Map UUID Fingerprint -> String
genAuthList = unlines . map fmt . M.toList
import Utility.FileMode
import Utility.ThreadScheduler
import Utility.SafeOutput
-import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import qualified Utility.MagicWormhole as Wormhole
-- files. Permissions of received files may allow others
-- to read them. So, set up a temp directory that only
-- we can read.
- withTmpDir (toOsPath "pair") $ \tmp -> do
- liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath tmp) $
+ withTmpDir (literalOsPath "pair") $ \tmp -> do
+ liftIO $ void $ tryIO $ modifyFileMode tmp $
removeModes otherGroupModes
- let sendf = tmp </> "send"
- let recvf = tmp </> "recv"
- liftIO $ writeFileProtected (toRawFilePath sendf) $
+ let sendf = tmp </> literalOsPath "send"
+ let recvf = tmp </> literalOsPath "recv"
+ liftIO $ writeFileProtected sendf $
serializePairData ourpairdata
observer <- liftIO Wormhole.mkCodeObserver
-- the same channels that other wormhole users use.
let appid = Wormhole.appId "git-annex.branchable.com/p2p-setup"
(sendres, recvres) <- liftIO $
- Wormhole.sendFile sendf observer appid
+ Wormhole.sendFile (fromOsPath sendf) observer appid
`concurrently`
- Wormhole.receiveFile recvf producer appid
- liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath sendf)
+ Wormhole.receiveFile (fromOsPath recvf) producer appid
+ liftIO $ removeWhenExistsWith removeFile sendf
if sendres /= True
then return SendFailed
else if recvres /= True
then return ReceiveFailed
else do
r <- liftIO $ tryIO $
- map decodeBS . fileLines' <$> F.readFile'
- (toOsPath (toRawFilePath recvf))
+ map decodeBS . fileLines'
+ <$> F.readFile' recvf
case r of
Left _e -> return ReceiveFailed
Right ls -> maybe
findRepos :: Options -> IO [Git.Repo]
findRepos o = do
files <- concat
- <$> mapM (dirContents . toRawFilePath) (directoryOption o)
+ <$> mapM (dirContents . toOsPath) (directoryOption o)
map Git.Construct.newFrom . catMaybes
<$> mapM Git.Construct.checkForRepo files
module Command.PostReceive where
+import Common
import Command
import qualified Annex
import Annex.UpdateInstead
fixPostReceiveHookEnv = do
g <- Annex.gitRepo
case location g of
- Local { gitdir = ".", worktree = Just "." } ->
+ l@(Local {}) | gitdir l == literalOsPath "." && worktree l == Just (literalOsPath ".") ->
Annex.adjustGitRepo $ \g' -> pure $ g'
{ location = case location g' of
loc@(Local {}) -> loc
- { worktree = Just ".." }
+ { worktree = Just (literalOsPath "..") }
loc -> loc
}
_ -> noop
-
addViewMetaData v f k = starting "metadata" ai si $
next $ changeMetaData k $ fromView v f
where
- ai = mkActionItem (k, toRawFilePath f)
+ ai = mkActionItem (k, f)
si = SeekInput []
removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart
removeViewMetaData v f k = starting "metadata" ai si $
next $ changeMetaData k $ unsetMetaData $ fromView v f
where
- ai = mkActionItem (k, toRawFilePath f)
+ ai = mkActionItem (k, f)
si = SeekInput []
changeMetaData :: Key -> MetaData -> CommandCleanup
-- Split on the last space, since a FilePath can contain whitespace,
-- but a Key very rarely does.
-batchParser :: String -> Annex (Either String (RawFilePath, Key))
+batchParser :: String -> Annex (Either String (OsPath, Key))
batchParser s = case separate (== ' ') (reverse s) of
(rk, rf)
| null rk || null rf -> return $ Left "Expected: \"file key\""
Nothing -> return $ Left "bad key"
Just k -> do
let f = reverse rf
- f' <- liftIO $ relPathCwdToFile (toRawFilePath f)
+ f' <- liftIO $ relPathCwdToFile (toOsPath f)
return $ Right (f', k)
seek :: ReKeyOptions -> CommandSeek
(reKeyThese o)
where
parsekey (file, skey) =
- (toRawFilePath file, fromMaybe (giveup "bad key") (deserializeKey skey))
+ (toOsPath file, fromMaybe (giveup "bad key") (deserializeKey skey))
-start :: SeekInput -> (RawFilePath, Key) -> CommandStart
+start :: SeekInput -> (OsPath, Key) -> CommandStart
start si (file, newkey) = lookupKey file >>= \case
Just k -> go k
Nothing -> stop
ai = ActionItemTreeFile file
-perform :: RawFilePath -> Key -> Key -> CommandPerform
+perform :: OsPath -> Key -> Key -> CommandPerform
perform file oldkey newkey = do
ifM (inAnnex oldkey)
( unlessM (linkKey file oldkey newkey) $
{- Make a hard link to the old key content (when supported),
- to avoid wasting disk space. -}
-linkKey :: RawFilePath -> Key -> Key -> Annex Bool
+linkKey :: OsPath -> Key -> Key -> Annex Bool
linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file)
( linkKey' DefaultVerify oldkey newkey
, do
- it's hard linked to the old key, that link must be broken. -}
oldobj <- calcRepo (gitAnnexLocation oldkey)
v <- tryNonAsync $ do
- st <- liftIO $ R.getFileStatus file
+ st <- liftIO $ R.getFileStatus (fromOsPath file)
when (linkCount st > 1) $ do
freezeContent oldobj
replaceWorkTreeFile file $ \tmp -> do
oldobj <- calcRepo (gitAnnexLocation oldkey)
isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing
-cleanup :: RawFilePath -> Key -> (MigrationRecord -> Annex ()) -> CommandCleanup
+cleanup :: OsPath -> Key -> (MigrationRecord -> Annex ()) -> CommandCleanup
cleanup file newkey a = do
newkeyrec <- ifM (isJust <$> isAnnexLink file)
( do
stageSymlink file sha
return (MigrationRecord sha)
, do
- mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
+ mode <- liftIO $ catchMaybeIO $
+ fileMode <$> R.getFileStatus (fromOsPath file)
liftIO $ whenM (isJust <$> isPointerFile file) $
writePointerFile file newkey mode
sha <- hashPointerFile newkey
go tmp = unVerified $ do
opts <- filterRsyncSafeOptions . maybe [] words
<$> getField "RsyncOptions"
- liftIO $ rsyncServerReceive (map Param opts) (fromRawFilePath tmp)
+ liftIO $ rsyncServerReceive (map Param opts) (fromOsPath tmp)
startSrcDest (si, (src, dest))
| src == dest = stop
| otherwise = starting "reinject" ai si $ notAnnexed src' $
- lookupKey (toRawFilePath dest) >>= \case
+ lookupKey (toOsPath dest) >>= \case
Just key -> ifM (verifyKeyContent key src')
( perform src' key
, do
qp <- coreQuotePath <$> Annex.getGitConfig
giveup $ decodeBS $ quote qp $ QuotedPath src'
<> " does not have expected content of "
- <> QuotedPath (toRawFilePath dest)
+ <> QuotedPath (toOsPath dest)
)
Nothing -> do
qp <- coreQuotePath <$> Annex.getGitConfig
giveup $ decodeBS $ quote qp $ QuotedPath src'
<> " is not an annexed file"
where
- src' = toRawFilePath src
+ src' = toOsPath src
ai = ActionItemOther (Just (QuotedPath src'))
startGuessKeys :: FilePath -> CommandStart
startGuessKeys src = starting "reinject" ai si $ notAnnexed src' $
- case fileKey (toRawFilePath (takeFileName src)) of
+ case fileKey (takeFileName src') of
Just key -> ifM (verifyKeyContent key src')
( perform src' key
, do
warning "Not named like an object file; skipping"
next $ return True
where
- src' = toRawFilePath src
+ src' = toOsPath src
ai = ActionItemOther (Just (QuotedPath src'))
si = SeekInput [src]
next $ return True
)
where
- src' = toRawFilePath src
+ src' = toOsPath src
ks = KeySource src' src' Nothing
ai = ActionItemOther (Just (QuotedPath src'))
si = SeekInput [src]
-notAnnexed :: RawFilePath -> CommandPerform -> CommandPerform
+notAnnexed :: OsPath -> CommandPerform -> CommandPerform
notAnnexed src a =
ifM (fromRepo Git.repoIsLocalBare)
( a
Nothing -> a
)
-perform :: RawFilePath -> Key -> CommandPerform
+perform :: OsPath -> Key -> CommandPerform
perform src key = do
maybeAddJSONField "key" (serializeKey key)
ifM move
| foregroundDaemonOption o = liftIO runInteractive
| otherwise = do
#ifndef mingw32_HOST_OS
- git_annex <- liftIO programPath
+ git_annex <- fromOsPath <$> liftIO programPath
ps <- gitAnnexDaemonizeParams
let logfd = openFdWithMode (toRawFilePath "/dev/null") ReadOnly Nothing defaultFileFlags
liftIO $ daemonize git_annex ps logfd Nothing False runNonInteractive
import qualified Git.Ref
import Git.Types
import Annex.Version
-import qualified Utility.RawFilePath as R
cmd :: Command
cmd = noCommit $ dontCheck repoExists $
Annex.Branch.forceCommit "committing index after git repository repair"
liftIO $ putStrLn "Successfully recovered the git-annex branch using .git/annex/index"
nukeindex = do
- inRepo $ removeWhenExistsWith R.removeLink . gitAnnexIndex
+ inRepo $ removeWhenExistsWith removeFile . gitAnnexIndex
liftIO $ putStrLn "Had to delete the .git/annex/index file as it was corrupt."
missingbranch = liftIO $ putStrLn "Since the git-annex branch is not up-to-date anymore. It would be a very good idea to run: git annex fsck --fast"
import Annex.AutoMerge
import qualified Utility.FileIO as F
-import qualified System.FilePath.ByteString as P
-
cmd :: Command
cmd = command "resolvemerge" SectionPlumbing
"resolve merge conflicts"
start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do
us <- fromMaybe nobranch <$> inRepo Git.Branch.current
d <- fromRepo Git.localGitDir
- let merge_head = toOsPath $ d P.</> "MERGE_HEAD"
+ let merge_head = d </> literalOsPath "MERGE_HEAD"
them <- fromMaybe (giveup nomergehead) . extractSha
<$> liftIO (F.readFile' merge_head)
ifM (resolveMerge (Just us) them False)
)
where
nobranch = giveup "No branch is currently checked out."
- nomergehead = giveup "No SHA found in .git/merge_head"
+ nomergehead = giveup "No SHA found in .git/MERGE_HEAD"
seek o = case batchOption o of
Batch fmt -> batchOnly Nothing (rmThese o) $
batchInput fmt batchParser (batchCommandAction . start)
- NoBatch -> withPairs (commandAction . start) (rmThese o)
+ NoBatch -> withPairs (commandAction . start . conv) (rmThese o)
+ where
+ conv (si, (f, u)) = (si, (toOsPath f, u))
--- Split on the last space, since a FilePath can contain whitespace,
+-- Split on the last space, since a OsPath can contain whitespace,
-- but a url should not.
-batchParser :: String -> Annex (Either String (FilePath, URLString))
+batchParser :: String -> Annex (Either String (OsPath, URLString))
batchParser s = case separate (== ' ') (reverse s) of
(ru, rf)
| null ru || null rf -> return $ Left "Expected: \"file url\""
| otherwise -> do
- let f = reverse rf
- f' <- liftIO $ fromRawFilePath
- <$> relPathCwdToFile (toRawFilePath f)
+ let f = toOsPath (reverse rf)
+ f' <- liftIO $ relPathCwdToFile f
return $ Right (f', reverse ru)
-start :: (SeekInput, (FilePath, URLString)) -> CommandStart
-start (si, (file, url)) = lookupKeyStaged file' >>= \case
+start :: (SeekInput, (OsPath, URLString)) -> CommandStart
+start (si, (file, url)) = lookupKeyStaged file >>= \case
Nothing -> stop
Just key -> do
- let ai = mkActionItem (key, AssociatedFile (Just file'))
+ let ai = mkActionItem (key, AssociatedFile (Just file))
starting "rmurl" ai si $
next $ cleanup url key
- where
- file' = toRawFilePath file
cleanup :: String -> Key -> CommandCleanup
cleanup url key = do
ifM (inAnnex key)
( fieldTransfer Upload key $ \_p ->
sendAnnex key Nothing rollback $ \f _sz ->
- liftIO $ rsyncServerSend (map Param opts) f
+ liftIO $ rsyncServerSend
+ (map Param opts)
+ (fromOsPath f)
, do
warning "requested key is not present"
liftIO exitFailure
where
ai = ActionItemOther (Just (QuotedPath file'))
si = SeekInput ps
- file' = toRawFilePath file
+ file' = toOsPath file
start _ = giveup "specify a key and a content file"
keyOpt :: String -> Key
keyOpt = fromMaybe (giveup "bad key") . deserializeKey
-perform :: RawFilePath -> Key -> CommandPerform
+perform :: OsPath -> Key -> CommandPerform
perform file key = do
-- the file might be on a different filesystem, so moveFile is used
-- rather than simply calling moveAnnex; disk space is also
startsim' :: Maybe FilePath -> Annex (SimState SimRepo)
startsim' simfile = do
- simdir <- fromRawFilePath <$> fromRepo gitAnnexSimDir
+ simdir <- fromRepo gitAnnexSimDir
whenM (liftIO $ doesDirectoryExist simdir) $
giveup "A sim was previously started. Use `git-annex sim end` to stop it before starting a new one."
showLongNote $ UnquotedString "Sim started."
rng <- liftIO $ fst . random <$> getStdGen
- let st = emptySimState rng simdir
+ let st = emptySimState rng (fromOsPath simdir)
case simfile of
Nothing -> startup simdir st []
Just f -> liftIO (readFile f) >>= \c ->
where
startup simdir st cs = do
repobyname <- mkGetExistingRepoByName
- createAnnexDirectory (toRawFilePath simdir)
+ createAnnexDirectory simdir
let st' = recordSeed st cs
go st' repobyname cs
endsim :: CommandSeek
endsim = do
- simdir <- fromRawFilePath <$> fromRepo gitAnnexSimDir
+ simdir <- fromRepo gitAnnexSimDir
whenM (liftIO $ doesDirectoryExist simdir) $ do
liftIO $ removeDirectoryRecursive simdir
showLongNote $ UnquotedString "Sim ended."
paramFile (seek <$$> optParser)
data SmudgeOptions = UpdateOption | SmudgeOptions
- { smudgeFile :: FilePath
+ { smudgeFile :: OsPath
, cleanOption :: Bool
}
optParser desc = smudgeoptions <|> updateoption
where
smudgeoptions = SmudgeOptions
- <$> argument str ( metavar desc )
+ <$> (stringToOsPath <$> argument str ( metavar desc ))
<*> switch ( long "clean" <> help "clean filter" )
updateoption = flag' UpdateOption
( long "update" <> help "populate annexed worktree files" )
seek :: SmudgeOptions -> CommandSeek
seek (SmudgeOptions f False) = commandAction (smudge f)
-seek (SmudgeOptions f True) = commandAction (clean (toRawFilePath f))
+seek (SmudgeOptions f True) = commandAction (clean f)
seek UpdateOption = commandAction update
-- Smudge filter is fed git file content, and if it's a pointer to an
-- * To support annex.thin
-- * Because git currently buffers the whole object received from the
-- smudge filter in memory, which is a problem with large files.
-smudge :: FilePath -> CommandStart
+smudge :: OsPath -> CommandStart
smudge file = do
b <- liftIO $ L.hGetContents stdin
smudge' file b
stop
-- Handles everything except the IO of the file content.
-smudge' :: FilePath -> L.ByteString -> Annex ()
+smudge' :: OsPath -> L.ByteString -> Annex ()
smudge' file b = case parseLinkTargetOrPointerLazy b of
Nothing -> noop
Just k -> do
- topfile <- inRepo (toTopFilePath (toRawFilePath file))
+ topfile <- inRepo (toTopFilePath file)
Database.Keys.addAssociatedFile k topfile
void $ smudgeLog k topfile
-- Clean filter is fed file content on stdin, decides if a file
-- should be stored in the annex, and outputs a pointer to its
-- injested content if so. Otherwise, the original content.
-clean :: RawFilePath -> CommandStart
+clean :: OsPath -> CommandStart
clean file = do
Annex.BranchState.disableUpdate -- optimisation
b <- liftIO $ L.hGetContents stdin
-- Handles everything except the IO of the file content.
clean'
- :: RawFilePath
+ :: OsPath
-> Either InvalidAppendedPointerFile (Maybe Key)
-- ^ If the content provided by git is an annex pointer,
-- this is the key it points to.
emitpointer
=<< postingest
=<< (\ld -> ingest' preferredbackend nullMeterUpdate ld Nothing norestage)
- =<< lockDown cfg (fromRawFilePath file)
+ =<< lockDown cfg file
postingest (Just k, _) = do
logStatus NoLiveUpdate k InfoPresent
-- git diff can run the clean filter on files outside the
-- repository; can't annex those
-fileOutsideRepo :: RawFilePath -> Annex Bool
+fileOutsideRepo :: OsPath -> Annex Bool
fileOutsideRepo file = do
repopath <- liftIO . absPath =<< fromRepo Git.repoPath
filepath <- liftIO $ absPath file
-- in the index, and has the same content, leave it in git.
-- This handles cases such as renaming a file followed by git add,
-- which the user naturally expects to behave the same as git mv.
-shouldAnnex :: RawFilePath -> Maybe (Sha, FileSize, ObjectType) -> Maybe Key -> Annex Bool
+shouldAnnex :: OsPath -> Maybe (Sha, FileSize, ObjectType) -> Maybe Key -> Annex Bool
shouldAnnex file indexmeta moldkey = do
ifM (annexGitAddToAnnex <$> Annex.getGitConfig)
( checkunchanged $ checkmatcher checkwasannexed
-- This also handles the case where a copy of a pointer file is made,
-- then git-annex gets the content, and later git add is run on
-- the pointer copy. It will then be populated with the content.
-getMoveRaceRecovery :: Key -> RawFilePath -> Annex ()
+getMoveRaceRecovery :: Key -> OsPath -> Annex ()
getMoveRaceRecovery k file = void $ tryNonAsync $
whenM (inAnnex k) $ do
obj <- calcRepo (gitAnnexLocation k)
absf <- fromRepo $ fromTopFilePath (statusFile s)
f <- liftIO $ relPathCwdToFile absf
qp <- coreQuotePath <$> Annex.getGitConfig
- unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", fromRawFilePath f)]) $
+ unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", fromOsPath f)]) $
liftIO $ B8.putStrLn $ quote qp $
UnquotedString (c : " ") <> QuotedPath f
, pushOption :: Bool
, contentOption :: Maybe Bool
, noContentOption :: Maybe Bool
- , contentOfOption :: [FilePath]
+ , contentOfOption :: [OsPath]
, cleanupOption :: Bool
, keyOptions :: Maybe KeyOptions
, resolveMergeOverride :: Bool
<> short 'g'
<> help "do not transfer annexed file contents"
)))
- <*> many (strOption
+ <*> many (stringToOsPath <$> strOption
( long "content-of"
<> short 'C'
<> help "transfer contents of annexed files in a given location"
<*> pure (pushOption v)
<*> pure (contentOption v)
<*> pure (noContentOption v)
- <*> liftIO (mapM (fromRawFilePath <$$> absPath . toRawFilePath) (contentOfOption v))
+ <*> liftIO (mapM absPath (contentOfOption v))
<*> pure (cleanupOption v)
<*> pure (keyOptions v)
<*> pure (resolveMergeOverride v)
- of the repo. This also means that sync always acts on all files in the
- repository, not just on a subdirectory. -}
prepMerge :: Annex ()
-prepMerge = Annex.changeDirectory . fromRawFilePath =<< fromRepo Git.repoPath
+prepMerge = Annex.changeDirectory =<< fromRepo Git.repoPath
mergeConfig :: Bool -> Annex [Git.Merge.MergeConfig]
mergeConfig mergeunrelated = do
Nothing -> return True
Just wt -> ifM needemulation
( gitAnnexChildProcess "post-receive" []
- (\cp -> cp { cwd = Just (fromRawFilePath wt) })
+ (\cp -> cp { cwd = Just (fromOsPath wt) })
(\_ _ _ pid -> waitForProcess pid >>= return . \case
ExitSuccess -> True
_ -> False
)
_ -> case currbranch of
(Just origbranch, Just adj) | adjustmentHidesFiles adj -> do
- l <- workTreeItems' (AllowHidden True) ww (contentOfOption o)
+ l <- workTreeItems' (AllowHidden True) ww
+ (map fromOsPath (contentOfOption o))
seekincludinghidden origbranch mvar l (const noop)
pure Nothing
_ -> do
- l <- workTreeItems ww (contentOfOption o)
+ l <- workTreeItems ww
+ (map fromOsPath (contentOfOption o))
seekworktree mvar l (const noop)
pure Nothing
waitForAllRunningCommandActions
mtree <- inRepo $ Git.Ref.tree b
let addsubdir = case snd (splitRemoteAnnexTrackingBranchSubdir b) of
Just subdir -> \cb -> Git.Ref $
- Git.fromRef' cb <> ":" <> getTopFilePath subdir
+ Git.fromRef' cb <> ":" <> fromOsPath (getTopFilePath subdir)
Nothing -> id
mcurrtree <- maybe (pure Nothing)
(inRepo . Git.Ref.tree . addsubdir)
showAction "generating test keys"
NE.fromList
<$> mapM randKey (keySizes basesz fast)
- fs -> NE.fromList
- <$> mapM (getReadonlyKey r . toRawFilePath) fs
+ fs -> NE.fromList <$> mapM (getReadonlyKey r . toOsPath) fs
let r' = if null (testReadonlyFile o)
then r
else r { Remote.readonly = True }
get r k
, check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from 0" $ \r k -> do
- tmp <- toOsPath <$> prepTmp k
+ tmp <- prepTmp k
liftIO $ F.writeFile' tmp mempty
lockContentForRemoval k noop removeAnnex
get r k
, check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from 33%" $ \r k -> do
- loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)
- tmp <- toOsPath <$> prepTmp k
- partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do
+ loc <- Annex.calcRepo (gitAnnexLocation k)
+ tmp <- prepTmp k
+ partial <- liftIO $ bracket (F.openBinaryFile loc ReadMode) hClose $ \h -> do
sz <- hFileSize h
L.hGet h $ fromInteger $ sz `div` 3
liftIO $ F.writeFile tmp partial
get r k
, check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from end" $ \r k -> do
- loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)
- tmp <- fromRawFilePath <$> prepTmp k
+ loc <- Annex.calcRepo (gitAnnexLocation k)
+ tmp <- prepTmp k
void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp
lockContentForRemoval k noop removeAnnex
get r k
loc <- Annex.calcRepo (gitAnnexLocation k)
verifier k loc
get r k = logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest ->
- tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case
+ tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate (RemoteVerify r)) >>= \case
Right v -> return (True, v)
Left _ -> return (False, UnVerified)
store r k = Remote.storeKey r k (AssociatedFile Nothing) Nothing nullMeterUpdate
-- renames are not tested because remotes do not need to support them
]
where
- testexportdirectory = "testremote-export"
- testexportlocation = mkExportLocation (toRawFilePath (testexportdirectory </> "location"))
+ testexportdirectory = literalOsPath "testremote-export"
+ testexportlocation = mkExportLocation (testexportdirectory </> literalOsPath "location")
check desc a = testCase desc $ do
let a' = mkr >>= \case
Just r -> do
Nothing -> return True
runannex a' @? "failed"
storeexport ea k = do
- loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)
+ loc <- Annex.calcRepo (gitAnnexLocation k)
Remote.storeExport ea loc k testexportlocation nullMeterUpdate
- retrieveexport ea k = withTmpFile (toOsPath "exported") $ \tmp h -> do
+ retrieveexport ea k = withTmpFile (literalOsPath "exported") $ \tmp h -> do
liftIO $ hClose h
- tryNonAsync (Remote.retrieveExport ea k testexportlocation (fromRawFilePath (fromOsPath tmp)) nullMeterUpdate) >>= \case
+ tryNonAsync (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate) >>= \case
Left _ -> return False
- Right v -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify v k (fromOsPath tmp)
+ Right v -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify v k tmp
checkpresentexport ea k = Remote.checkPresentExport ea k testexportlocation
removeexport ea k = Remote.removeExport ea k testexportlocation
removeexportdirectory ea = case Remote.removeExportDirectory ea of
- Just a -> a (mkExportDirectory (toRawFilePath testexportdirectory))
+ Just a -> a (mkExportDirectory testexportdirectory)
Nothing -> noop
testUnavailable :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree]
Remote.checkPresent r k
, check (== Right False) "retrieveKeyFile" $ \r k ->
logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest ->
- tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case
+ tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate (RemoteVerify r)) >>= \case
Right v -> return (True, v)
Left _ -> return (False, UnVerified)
, check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of
Nothing -> return False
Just a -> logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest ->
unVerified $ isRight
- <$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest))
+ <$> tryNonAsync (a k (AssociatedFile Nothing) dest)
]
where
check checkval desc a = testCase desc $
| otherwise = sz > 0
randKey :: Int -> Annex Key
-randKey sz = withTmpFile (toOsPath "randkey") $ \f h -> do
+randKey sz = withTmpFile (literalOsPath "randkey") $ \f h -> do
gen <- liftIO (newGenIO :: IO SystemRandom)
case genBytes sz gen of
Left e -> giveup $ "failed to generate random key: " ++ show e
Right (rand, _) -> liftIO $ B.hPut h rand
liftIO $ hClose h
let ks = KeySource
- { keyFilename = fromOsPath f
- , contentLocation = fromOsPath f
+ { keyFilename = f
+ , contentLocation = f
, inodeCache = Nothing
}
k <- case Types.Backend.genKey Backend.Hash.testKeyBackend of
Just a -> a ks nullMeterUpdate
Nothing -> giveup "failed to generate random key (backend problem)"
- _ <- moveAnnex k (AssociatedFile Nothing) (fromOsPath f)
+ _ <- moveAnnex k (AssociatedFile Nothing) f
return k
-getReadonlyKey :: Remote -> RawFilePath -> Annex Key
+getReadonlyKey :: Remote -> OsPath -> Annex Key
getReadonlyKey r f = do
qp <- coreQuotePath <$> Annex.getGitConfig
lookupKey f >>= \case
optParser desc = TransferKeyOptions
<$> cmdParams desc
<*> parseFromToOptions
- <*> (AssociatedFile <$> optional (strOption
+ <*> (AssociatedFile . fmap stringToOsPath <$> optional (strOption
( long "file" <> metavar paramFile
<> help "the associated file"
)))
fromPerform key af remote = go Upload af $
download' (uuid remote) key af Nothing stdRetry $ \p ->
logStatusAfter NoLiveUpdate key $ getViaTmp (retrievalSecurityPolicy remote) vc key af Nothing $ \t ->
- tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p vc) >>= \case
+ tryNonAsync (Remote.retrieveKeyFile remote key af t p vc) >>= \case
Right v -> return (True, v)
Left e -> do
warning (UnquotedString (show e))
| otherwise = notifyTransfer direction af $
download' (Remote.uuid remote) key af Nothing stdRetry $ \p ->
logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do
- r <- tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote)) >>= \case
+ r <- tryNonAsync (Remote.retrieveKeyFile remote key af t p (RemoteVerify remote)) >>= \case
Left e -> do
warning (UnquotedString (show e))
return (False, UnVerified)
deserialize _ = Nothing
instance TCSerialized AssociatedFile where
- serialize (AssociatedFile (Just f)) = fromRawFilePath f
+ serialize (AssociatedFile (Just f)) = fromOsPath f
serialize (AssociatedFile Nothing) = ""
deserialize "" = Just (AssociatedFile Nothing)
- deserialize f = Just (AssociatedFile (Just (toRawFilePath f)))
+ deserialize f = Just (AssociatedFile (Just (toOsPath f)))
instance TCSerialized RemoteName where
serialize n = n
-- and for retrying, and updating location log,
-- and stall canceling.
let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do
- Remote.verifiedAction (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote))
+ Remote.verifiedAction (Remote.retrieveKeyFile remote key af t p (RemoteVerify remote))
in download' (Remote.uuid remote) key af Nothing noRetry go
noNotification
runner (AssistantUploadRequest _ key (TransferAssociatedFile af)) remote =
notifyTransfer Download file $
download' (Remote.uuid remote) key file Nothing stdRetry $ \p ->
logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do
- r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case
+ r <- tryNonAsync (Remote.retrieveKeyFile remote key file t p (RemoteVerify remote)) >>= \case
Left e -> do
warning (UnquotedString (show e))
return (False, UnVerified)
, usesLocationLog = False
}
-start :: Bool -> SeekInput -> RawFilePath -> Key -> CommandStart
+start :: Bool -> SeekInput -> OsPath -> Key -> CommandStart
start fast si file key =
starting "unannex" (mkActionItem (key, file)) si $
perform fast file key
-perform :: Bool -> RawFilePath -> Key -> CommandPerform
+perform :: Bool -> OsPath -> Key -> CommandPerform
perform fast file key = do
Annex.Queue.addCommand [] "rm"
[ Param "--cached"
, Param "--quiet"
, Param "--"
]
- [fromRawFilePath file]
+ [fromOsPath file]
isAnnexLink file >>= \case
-- If the file is locked, it needs to be replaced with
-- the content from the annex. Note that it's possible
maybe noop Database.Keys.removeInodeCache
=<< withTSDelta (liftIO . genInodeCache file)
-cleanup :: Bool -> RawFilePath -> Key -> CommandCleanup
+cleanup :: Bool -> OsPath -> Key -> CommandCleanup
cleanup fast file key = do
- liftIO $ removeFile (fromRawFilePath file)
+ liftIO $ removeFile file
src <- calcRepo (gitAnnexLocation key)
ifM (pure fast <||> Annex.getRead Annex.fast)
( do
-- already have other hard links pointing at it. This
-- avoids unannexing (and uninit) ending up hard
-- linking files together, which would be surprising.
- s <- liftIO $ R.getFileStatus src
+ s <- liftIO $ R.getFileStatus (fromOsPath src)
if linkCount s > 1
then copyfrom src
else hardlinkfrom src
)
where
copyfrom src =
- thawContent file `after` liftIO
- (copyFileExternal CopyAllMetaData
- (fromRawFilePath src)
- (fromRawFilePath file))
+ thawContent file `after`
+ liftIO (copyFileExternal CopyAllMetaData src file)
hardlinkfrom src =
-- creating a hard link could fall; fall back to copying
- ifM (liftIO $ catchBoolIO $ R.createLink src file >> return True)
+ ifM (liftIO $ tryhardlink src file)
( return True
, copyfrom src
)
+ tryhardlink src dest = catchBoolIO $ do
+ R.createLink (fromOsPath src) (fromOsPath dest)
+ return True
import qualified Git.LsFiles as LsFiles
import qualified Git.Command as Git
import qualified Git.Branch
-import qualified Utility.RawFilePath as R
cmd :: Command
cmd = notBareRepo $ withAnnexOptions [jsonOptions] $
seek ps = do
-- Safety first; avoid any undo that would touch files that are not
-- in the index.
- (fs, cleanup) <- inRepo $ LsFiles.notInRepo [] False (map toRawFilePath ps)
+ (fs, cleanup) <- inRepo $ LsFiles.notInRepo [] False (map toOsPath ps)
unless (null fs) $ do
qp <- coreQuotePath <$> Annex.getGitConfig
giveup $ decodeBS $ quote qp $
start :: FilePath -> CommandStart
start p = starting "undo" ai si $
- perform p
+ perform p'
where
- ai = ActionItemOther (Just (QuotedPath (toRawFilePath p)))
+ p' = toOsPath p
+ ai = ActionItemOther (Just (QuotedPath p'))
si = SeekInput [p]
-perform :: FilePath -> CommandPerform
+perform :: OsPath -> CommandPerform
perform p = do
g <- gitRepo
-- Get the reversed diff that needs to be applied to undo.
(diff, cleanup) <- inRepo $
- diffLog [Param "-R", Param "--", Param p]
- top <- inRepo $ toTopFilePath $ toRawFilePath p
+ diffLog [Param "-R", Param "--", Param (fromOsPath p)]
+ top <- inRepo $ toTopFilePath p
let diff' = filter (`isDiffOf` top) diff
liftIO $ streamUpdateIndex g (map stageDiffTreeItem diff')
forM_ removals $ \di -> do
f <- mkrel di
- liftIO $ removeWhenExistsWith R.removeLink f
+ liftIO $ removeWhenExistsWith removeFile f
forM_ adds $ \di -> do
- f <- fromRawFilePath <$> mkrel di
+ f <- fromOsPath <$> mkrel di
inRepo $ Git.run [Param "checkout", Param "--", File f]
next $ liftIO cleanup
when (b == Just Annex.Branch.name) $ giveup $
"cannot uninit when the " ++ Git.fromRef Annex.Branch.name ++ " branch is checked out"
top <- fromRepo Git.repoPath
- currdir <- liftIO R.getCurrentDirectory
+ currdir <- liftIO getCurrentDirectory
whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $
giveup "can only run uninit from the top of the git repository"
{- git annex symlinks that are not checked into git could be left by an
- interrupted add. -}
-startCheckIncomplete :: Annex () -> RawFilePath -> Key -> CommandStart
+startCheckIncomplete :: Annex () -> OsPath -> Key -> CommandStart
startCheckIncomplete recordnotok file key =
starting "uninit check" (mkActionItem (file, key)) (SeekInput []) $ do
recordnotok
giveup $ unlines err
where
err =
- [ fromRawFilePath file ++ " points to annexed content, but is not checked into git."
+ [ fromOsPath file ++ " points to annexed content, but is not checked into git."
, "Perhaps this was left behind by an interrupted git annex add?"
, "Not continuing with uninit; either delete or git annex add the file and retry."
]
prepareRemoveAnnexDir annexdir
if null leftovers
then do
- liftIO $ removeDirectoryRecursive (fromRawFilePath annexdir)
+ liftIO $ removeDirectoryRecursive annexdir
next recordok
else giveup $ unlines
[ "Not fully uninitialized"
- , "Some annexed data is still left in " ++ fromRawFilePath annexobjectdir
+ , "Some annexed data is still left in " ++ fromOsPath annexobjectdir
, "This may include deleted files, or old versions of modified files."
, ""
, "If you don't care about preserving the data, just delete the"
-
- Also closes sqlite databases that might be in the directory,
- to avoid later failure to write any cached changes to them. -}
-prepareRemoveAnnexDir :: RawFilePath -> Annex ()
+prepareRemoveAnnexDir :: OsPath -> Annex ()
prepareRemoveAnnexDir annexdir = do
Database.Keys.closeDb
liftIO $ prepareRemoveAnnexDir' annexdir
-prepareRemoveAnnexDir' :: RawFilePath -> IO ()
+prepareRemoveAnnexDir' :: OsPath -> IO ()
prepareRemoveAnnexDir' annexdir =
emptyWhenDoesNotExist (dirTreeRecursiveSkipping (const False) annexdir)
>>= mapM_ (void . tryIO . allowWrite)
, go (k:c) ks
)
enoughlinks f = catchBoolIO $ do
- s <- R.getFileStatus f
+ s <- R.getFileStatus (fromOsPath f)
return $ linkCount s > 1
completeUnitialize :: CommandStart
, usesLocationLog = False
}
-start :: SeekInput -> RawFilePath -> Key -> CommandStart
+start :: SeekInput -> OsPath -> Key -> CommandStart
start si file key = ifM (isJust <$> isAnnexLink file)
( starting "unlock" ai si $ perform file key
, stop
where
ai = mkActionItem (key, AssociatedFile (Just file))
-perform :: RawFilePath -> Key -> CommandPerform
+perform :: OsPath -> Key -> CommandPerform
perform dest key = do
- destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus dest
+ destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath dest)
destic <- replaceWorkTreeFile dest $ \tmp -> do
ifM (inAnnex key)
( do
withTSDelta (liftIO . genInodeCache tmp)
next $ cleanup dest destic key destmode
-cleanup :: RawFilePath -> Maybe InodeCache -> Key -> Maybe FileMode -> CommandCleanup
+cleanup :: OsPath -> Maybe InodeCache -> Key -> Maybe FileMode -> CommandCleanup
cleanup dest destic key destmode = do
stagePointerFile dest destmode =<< hashPointerFile key
maybe noop (restagePointerFile (Restage True) dest) destic
maybeAddJSONField
((if null fileprefix then "unused" else fileprefix) ++ "-list")
(M.fromList $ map (\(n, k) -> (T.pack (show n), serializeKey k)) unusedlist)
- updateUnusedLog (toRawFilePath fileprefix) (M.fromList unusedlist)
+ updateUnusedLog (toOsPath fileprefix) (M.fromList unusedlist)
return $ c + length l
number :: Int -> [a] -> [(Int, a)]
{- Given an initial value, accumulates the value over each key
- referenced by files in the working tree. -}
-withKeysReferenced :: v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v
+withKeysReferenced :: v -> (Key -> OsPath -> v -> Annex v) -> Annex v
withKeysReferenced initial = withKeysReferenced' Nothing initial
{- Runs an action on each referenced key in the working tree. -}
calla k _ _ = a k
{- Folds an action over keys and files referenced in a particular directory. -}
-withKeysFilesReferencedIn :: FilePath -> v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v
+withKeysFilesReferencedIn :: OsPath -> v -> (Key -> OsPath -> v -> Annex v) -> Annex v
withKeysFilesReferencedIn = withKeysReferenced' . Just
-withKeysReferenced' :: Maybe FilePath -> v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v
+withKeysReferenced' :: Maybe OsPath -> v -> (Key -> OsPath -> v -> Annex v) -> Annex v
withKeysReferenced' mdir initial a = do
(files, clean) <- getfiles
r <- go initial files
top <- fromRepo Git.repoPath
inRepo $ LsFiles.allFiles [] [top]
)
- Just dir -> inRepo $ LsFiles.inRepo [] [toRawFilePath dir]
+ Just dir -> inRepo $ LsFiles.inRepo [] [dir]
go v [] = return v
go v (f:fs) = do
mk <- lookupKey f
withUnusedMaps :: (UnusedMaps -> Int -> CommandStart) -> CmdParams -> CommandSeek
withUnusedMaps a params = do
- unused <- readUnusedMap ""
- unusedbad <- readUnusedMap "bad"
- unusedtmp <- readUnusedMap "tmp"
+ unused <- readUnusedMap (literalOsPath "")
+ unusedbad <- readUnusedMap (literalOsPath "bad")
+ unusedtmp <- readUnusedMap (literalOsPath "tmp")
let m = unused `M.union` unusedbad `M.union` unusedtmp
let unusedmaps = UnusedMaps unused unusedbad unusedtmp
commandActions $ map (a unusedmaps) $ concatMap (unusedSpec m) params
import Remote
import Git.Types (fromConfigKey, fromConfigValue)
import Utility.DataUnits
-import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
cmd :: Command
start :: CommandStart
start = do
f <- fromRepo gitAnnexTmpCfgFile
- let f' = fromRawFilePath f
createAnnexDirectory $ parentDir f
cfg <- getCfg
descs <- uuidDescriptions
- liftIO $ writeFile f' $ genCfg cfg descs
- vicfg cfg f'
+ liftIO $ writeFile (fromOsPath f) $ genCfg cfg descs
+ vicfg cfg f
stop
-vicfg :: Cfg -> FilePath -> Annex ()
+vicfg :: Cfg -> OsPath -> Annex ()
vicfg curcfg f = do
vi <- liftIO $ catchDefaultIO "vi" $ getEnv "EDITOR"
- -- Allow EDITOR to be processed by the shell, so it can contain options.
- unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $
+ unlessM (liftIO $ boolSystem "sh" (shparams vi)) $
giveup $ vi ++ " exited nonzero; aborting"
r <- liftIO $ parseCfg (defCfg curcfg)
. map decodeBS
. fileLines'
- <$> F.readFile' (toOsPath (toRawFilePath f))
- liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
+ <$> F.readFile' f
+ liftIO $ removeWhenExistsWith removeFile f
case r of
Left s -> do
- liftIO $ writeFile f s
+ liftIO $ writeFile (fromOsPath f) s
vicfg curcfg f
Right newcfg -> setCfg curcfg newcfg
+ where
+ -- Allow EDITOR to be processed by the shell,
+ -- so it can contain options.
+ shparams editor =
+ [ Param "-c"
+ , Param $ unwords [editor, shellEscape (fromOsPath f)]
+ ]
data Cfg = Cfg
{ cfgTrustMap :: M.Map UUID (Down TrustLevel)
import Types.AdjustedBranch
import Annex.AdjustedBranch.Name
-import qualified System.FilePath.ByteString as P
-
cmd :: Command
cmd = notBareRepo $
command "view" SectionMetaData "enter a view branch"
forM_ l (removeemptydir top)
liftIO $ void cleanup
unlessM (liftIO $ doesDirectoryExist here) $ do
- showLongNote $ UnquotedString $ cwdmissing (fromRawFilePath top)
+ showLongNote $ UnquotedString $ cwdmissing (fromOsPath top)
return ok
where
removeemptydir top d = do
p <- inRepo $ toTopFilePath d
- liftIO $ tryIO $ removeDirectory $
- fromRawFilePath $ (top P.</> getTopFilePath p)
+ liftIO $ tryIO $ removeDirectory $ top </> getTopFilePath p
cwdmissing top = unlines
[ "This view does not include the subdirectory you are currently in."
, "Perhaps you should: cd " ++ top
listenPort' <- if isJust (listenPort o)
then pure (listenPort o)
else annexPort <$> Annex.getGitConfig
- ifM (checkpid <&&> checkshim (fromRawFilePath f))
+ ifM (checkpid <&&> checkshim f)
( if isJust (listenAddress o) || isJust (listenPort o)
then giveup "The assistant is already running, so --listen and --port cannot be used."
else do
- url <- liftIO . readFile . fromRawFilePath
+ url <- liftIO . readFile . fromOsPath
=<< fromRepo gitAnnexUrlFile
liftIO $ if isJust listenAddress'
then putStrLn url
- else liftIO $ openBrowser browser (fromRawFilePath f) url Nothing Nothing
+ else liftIO $ openBrowser browser f url Nothing Nothing
, do
startDaemon True True Nothing cannotrun listenAddress' listenPort' $ Just $
\origout origerr url htmlshim ->
)
checkpid = do
pidfile <- fromRepo gitAnnexPidFile
- liftIO $ isJust <$> checkDaemon (fromRawFilePath pidfile)
+ liftIO $ isJust <$> checkDaemon pidfile
checkshim f = liftIO $ doesFileExist f
notinitialized = do
g <- Annex.gitRepo
- liftIO $ cannotStartIn (Git.repoLocation g) "repository has not been initialized by git-annex"
+ liftIO $ cannotStartIn (Git.repoPath g) "repository has not been initialized by git-annex"
liftIO $ firstRun o
{- If HOME is a git repo, even if it's initialized for git-annex,
notHome = do
g <- Annex.gitRepo
d <- liftIO $ absPath (Git.repoPath g)
- h <- liftIO $ absPath . toRawFilePath =<< myHomeDir
+ h <- liftIO $ absPath . toOsPath =<< myHomeDir
return (d /= h)
{- When run without a repo, start the first available listed repository in
go ds
Right state -> void $ Annex.eval state $ do
whenM (fromRepo Git.repoIsLocalBare) $
- giveup $ d ++ " is a bare git repository, cannot run the webapp in it"
+ giveup $ fromOsPath d ++ " is a bare git repository, cannot run the webapp in it"
r <- callCommandAction $
start' False o
quiesce False
return r
-cannotStartIn :: FilePath -> String -> IO ()
-cannotStartIn d reason = warningIO $ "unable to start webapp in repository " ++ d ++ ": " ++ reason
+cannotStartIn :: OsPath -> String -> IO ()
+cannotStartIn d reason = warningIO $
+ "unable to start webapp in repository " ++ fromOsPath d ++ ": " ++ reason
{- Run the webapp without a repository, which prompts the user, makes one,
- changes to it, starts the regular assistant, and redirects the
(Just $ sendurlback v)
sendurlback v _origout _origerr url _htmlshim = putMVar v url
-openBrowser :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()
+openBrowser :: Maybe OsPath -> OsPath -> String -> Maybe Handle -> Maybe Handle -> IO ()
openBrowser mcmd htmlshim realurl outh errh = do
- htmlshim' <- fromRawFilePath <$> absPath (toRawFilePath htmlshim)
+ htmlshim' <- absPath htmlshim
openBrowser' mcmd htmlshim' realurl outh errh
-openBrowser' :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()
+openBrowser' :: Maybe OsPath -> OsPath -> String -> Maybe Handle -> Maybe Handle -> IO ()
openBrowser' mcmd htmlshim realurl outh errh =
ifM osAndroid
{- Android does not support file:// urls well, but neither
where
runbrowser url = do
let p = case mcmd of
- Just c -> proc c [url]
+ Just c -> proc (fromOsPath c) [url]
Nothing ->
#ifndef mingw32_HOST_OS
browserProc url
{- Windows hack to avoid using the full path,
- which might contain spaces that cause problems
- for browserProc. -}
- (browserProc (takeFileName htmlshim))
- { cwd = Just (takeDirectory htmlshim) }
+ (browserProc (fromOsPath (takeFileName htmlshim)))
+ { cwd = Just (fromOsPath (takeDirectory htmlshim)) }
#endif
hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url
hFlush stdout
hPutStrLn (fromMaybe stderr errh) "failed to start web browser"
{- web.browser is a generic git config setting for a web browser program -}
-webBrowser :: Git.Repo -> Maybe FilePath
+webBrowser :: Git.Repo -> Maybe OsPath
webBrowser = fmap fromConfigValue <$> Git.Config.getMaybe "web.browser"
-fileUrl :: FilePath -> String
-fileUrl file = "file://" ++ file
+fileUrl :: OsPath -> String
+fileUrl file = "file://" ++ fromOsPath file
display key (descBranchFilePath (BranchFilePath r tf))
return True
-searchLog :: Key -> [CommandParam] -> (S.ByteString -> [RawFilePath] -> Annex Bool) -> Annex Bool
+searchLog :: Key -> [CommandParam] -> (S.ByteString -> [OsPath] -> Annex Bool) -> Annex Bool
searchLog key ps a = do
(output, cleanup) <- Annex.inRepo $ Git.Command.pipeNullSplit ps'
found <- case output of
-- so a regexp is used. Since annex pointer files
-- may contain a newline followed by perhaps something
-- else, that is also matched.
- , Param ("-G" ++ escapeRegexp (fromRawFilePath (keyFile key)) ++ "($|\n)")
+ , Param ("-G" ++ escapeRegexp (fromOsPath (keyFile key)) ++ "($|\n)")
-- Skip commits where the file was deleted,
-- only find those where it was added or modified.
, Param "--diff-filter=ACMRTUX"
where
ww = WarnUnmatchLsFiles "whereis"
-start :: WhereisOptions -> M.Map UUID Remote -> SeekInput -> RawFilePath -> Key -> CommandStart
+start :: WhereisOptions -> M.Map UUID Remote -> SeekInput -> OsPath -> Key -> CommandStart
start o remotemap si file key =
startKeys o remotemap (si, key, mkActionItem (key, afile))
where
import Data.Monoid as X
import Data.Default as X
-import System.FilePath as X
import System.IO as X hiding (FilePath)
import System.Exit as X
import System.PosixCompat.Files as X (FileStatus)
setCrippledFileSystem b =
setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b)
-pidLockFile :: Annex (Maybe RawFilePath)
+pidLockFile :: Annex (Maybe OsPath)
#ifndef mingw32_HOST_OS
pidLockFile = ifM (annexPidLock <$> Annex.getGitConfig)
( Just <$> Annex.fromRepo gitAnnexPidLockFile
branch = Git.Ref b
subdir = if S.null p
then Nothing
- else Just (asTopFilePath p)
+ else Just (asTopFilePath (toOsPath p))
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Config.Files where
+import Common
import Utility.FreeDesktop
-import Utility.Exception
-
-import System.FilePath
{- ~/.config/git-annex/file -}
-userConfigFile :: FilePath -> IO FilePath
+userConfigFile :: OsPath -> IO OsPath
userConfigFile file = do
dir <- userConfigDir
- return $ dir </> "git-annex" </> file
+ return $ dir </> literalOsPath "git-annex" </> file
-autoStartFile :: IO FilePath
-autoStartFile = userConfigFile "autostart"
+autoStartFile :: IO OsPath
+autoStartFile = userConfigFile (literalOsPath "autostart")
{- The path to git-annex is written here; which is useful when something
- has installed it to some awful non-PATH location. -}
-programFile :: IO FilePath
-programFile = userConfigFile "program"
+programFile :: IO OsPath
+programFile = userConfigFile (literalOsPath "program")
{- A .noannex file in a git repository prevents git-annex from
- initializing that repository. The content of the file is returned. -}
-noAnnexFileContent :: Maybe FilePath -> IO (Maybe String)
+noAnnexFileContent :: Maybe OsPath -> IO (Maybe String)
noAnnexFileContent repoworktree = case repoworktree of
Nothing -> return Nothing
- Just wt -> catchMaybeIO (readFile (wt </> ".noannex"))
+ Just wt -> catchMaybeIO (readFile (fromOsPath (wt </> literalOsPath ".noannex")))
import Utility.Tmp
{- Returns anything listed in the autostart file (which may not exist). -}
-readAutoStartFile :: IO [FilePath]
+readAutoStartFile :: IO [OsPath]
readAutoStartFile = do
f <- autoStartFile
- filter valid . nub . map dropTrailingPathSeparator . lines
- <$> catchDefaultIO "" (readFile f)
+ filter valid . nub . map (dropTrailingPathSeparator . toOsPath) . lines
+ <$> catchDefaultIO "" (readFile (fromOsPath f))
where
-- Ignore any relative paths; some old buggy versions added eg "."
valid = isAbsolute
-modifyAutoStartFile :: ([FilePath] -> [FilePath]) -> IO ()
+modifyAutoStartFile :: ([OsPath] -> [OsPath]) -> IO ()
modifyAutoStartFile func = do
dirs <- readAutoStartFile
let dirs' = nubBy equalFilePath $ func dirs
when (dirs' /= dirs) $ do
f <- autoStartFile
- createDirectoryIfMissing True $
- fromRawFilePath (parentDir (toRawFilePath f))
- viaTmp (writeFile . fromRawFilePath . fromOsPath)
- (toOsPath (toRawFilePath f))
- (unlines dirs')
+ createDirectoryIfMissing True (parentDir f)
+ viaTmp (writeFile . fromRawFilePath . fromOsPath) f
+ (unlines (map fromOsPath dirs'))
{- Adds a directory to the autostart file. If the directory is already
- present, it's moved to the top, so it will be used as the default
- when opening the webapp. -}
-addAutoStartFile :: FilePath -> IO ()
+addAutoStartFile :: OsPath -> IO ()
addAutoStartFile path = do
- path' <- fromRawFilePath <$> absPath (toRawFilePath path)
+ path' <- absPath path
modifyAutoStartFile $ (:) path'
{- Removes a directory from the autostart file. -}
-removeAutoStartFile :: FilePath -> IO ()
+removeAutoStartFile :: OsPath -> IO ()
removeAutoStartFile path = do
- path' <- fromRawFilePath <$> absPath (toRawFilePath path)
+ path' <- absPath path
modifyAutoStartFile $
filter (not . equalFilePath path')
import qualified Utility.FileIO as F
import qualified Data.ByteString as S
-import qualified System.FilePath.ByteString as P
configureSmudgeFilter :: Annex ()
configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do
gfs <- readattr gf
gittop <- Git.localGitDir <$> gitRepo
liftIO $ unless ("filter=annex" `S.isInfixOf` (lfs <> gfs)) $ do
- createDirectoryUnder [gittop] (P.takeDirectory lf)
- F.writeFile' (toOsPath lf) $
+ createDirectoryUnder [gittop] (takeDirectory lf)
+ F.writeFile' lf $
linesFile' (lfs <> encodeBS ("\n" ++ unlines stdattr))
where
- readattr = liftIO . catchDefaultIO mempty . F.readFile' . toOsPath
+ readattr = liftIO . catchDefaultIO mempty . F.readFile'
configureSmudgeFilterProcess :: Annex ()
configureSmudgeFilterProcess =
deconfigureSmudgeFilter = do
lf <- Annex.fromRepo Git.attributesLocal
ls <- liftIO $ catchDefaultIO [] $
- map decodeBS . fileLines' <$> F.readFile' (toOsPath lf)
- liftIO $ writeFile (fromRawFilePath lf) $ unlines $
+ map decodeBS . fileLines' <$> F.readFile' lf
+ liftIO $ writeFile (fromOsPath lf) $ unlines $
filter (\l -> l `notElem` stdattr && not (null l)) ls
unsetConfig (ConfigKey "filter.annex.smudge")
unsetConfig (ConfigKey "filter.annex.clean")
import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher)
import Utility.Env (getEnv)
import Utility.Base64
-import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.ByteString.Char8 as S8
import qualified Data.Map as M
-import qualified System.FilePath.ByteString as P
{- A CredPair can be stored in a file, or in the environment, or
- in a remote's configuration. -}
data CredPairStorage = CredPairStorage
- { credPairFile :: FilePath
+ { credPairFile :: OsPath
, credPairEnvironment :: (String, String)
, credPairRemoteField :: RemoteConfigField
}
{- Stores the creds in a file inside gitAnnexCredsDir that only the user
- can read. -}
-writeCreds :: Creds -> FilePath -> Annex ()
+writeCreds :: Creds -> OsPath -> Annex ()
writeCreds creds file = do
d <- fromRepo gitAnnexCredsDir
createAnnexDirectory d
- liftIO $ writeFileProtected (d P.</> toRawFilePath file) creds
+ liftIO $ writeFileProtected (d </> file) creds
-readCreds :: FilePath -> Annex (Maybe Creds)
+readCreds :: OsPath -> Annex (Maybe Creds)
readCreds f = do
- f' <- toOsPath . toRawFilePath <$> credsFile f
+ f' <- credsFile f
liftIO $ catchMaybeIO $ decodeBS . S8.unlines . fileLines'
<$> F.readFile' f'
-credsFile :: FilePath -> Annex FilePath
+credsFile :: OsPath -> Annex OsPath
credsFile basefile = do
- d <- fromRawFilePath <$> fromRepo gitAnnexCredsDir
+ d <- fromRepo gitAnnexCredsDir
return $ d </> basefile
encodeCredPair :: CredPair -> Creds
l:p:[] -> Just (l, p)
_ -> Nothing
-removeCreds :: FilePath -> Annex ()
+removeCreds :: OsPath -> Annex ()
removeCreds file = do
d <- fromRepo gitAnnexCredsDir
- liftIO $ removeWhenExistsWith R.removeLink (d P.</> toRawFilePath file)
+ liftIO $ removeWhenExistsWith removeFile (d </> file)
includeCredsInfo :: ParsedRemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)]
includeCredsInfo pc@(ParsedRemoteConfig cm _) storage info = do
Cipher{} ->
let passphrase = cipherPassphrase cipher
in case statelessOpenPGPCommand c of
- Just sopcmd -> withTmpDir (toOsPath "sop") $ \d ->
+ Just sopcmd -> withTmpDir (literalOsPath "sop") $ \d ->
SOP.encryptSymmetric sopcmd passphrase
(SOP.EmptyDirectory d)
(statelessOpenPGPProfile c)
Cipher{} ->
let passphrase = cipherPassphrase cipher
in case statelessOpenPGPCommand c of
- Just sopcmd -> withTmpDir (toOsPath "sop") $ \d ->
+ Just sopcmd -> withTmpDir (literalOsPath "sop") $ \d ->
SOP.decryptSymmetric sopcmd passphrase
(SOP.EmptyDirectory d)
feeder reader
import qualified Data.ByteString.Char8 as B8
import System.Random
import Control.Concurrent
-import qualified System.FilePath.ByteString as P
#endif
benchmarkDbs :: CriterionMode -> Integer -> Annex ()
#ifdef WITH_BENCHMARK
-benchmarkDbs mode n = withTmpDirIn "." (toOsPath "benchmark") $ \tmpdir -> do
- db <- benchDb (toRawFilePath tmpdir) n
+benchmarkDbs mode n = withTmpDirIn (literalOsPath ".") (literalOsPath "benchmark") $ \tmpdir -> do
+ db <- benchDb tmpdir n
liftIO $ runMode mode
[ bgroup "keys database"
[ getAssociatedFilesHitBench db
}
fileN :: Integer -> TopFilePath
-fileN n = asTopFilePath (toRawFilePath ("file" ++ show n))
+fileN n = asTopFilePath (toOsPath ("file" ++ show n))
keyMiss :: Key
keyMiss = keyN 0 -- 0 is never stored
data BenchDb = BenchDb H.DbQueue Integer (MVar Integer)
-benchDb :: RawFilePath -> Integer -> Annex BenchDb
+benchDb :: OsPath -> Integer -> Annex BenchDb
benchDb tmpdir num = do
liftIO $ putStrLn $ "setting up database with " ++ show num ++ " items"
initDb db SQL.createTables
mv <- liftIO $ newMVar 1
return (BenchDb h num mv)
where
- db = tmpdir P.</> toRawFilePath (show num </> "db")
+ db = tmpdir </> toOsPath (show num) </> literalOsPath "db"
#endif /* WITH_BENCHMARK */
import qualified Git.DiffTree as DiffTree
import Logs
import qualified Logs.ContentIdentifier as Log
-import qualified Utility.RawFilePath as R
import Database.Persist.Sql hiding (Key)
import Database.Persist.TH
-import qualified System.FilePath.ByteString as P
#if MIN_VERSION_persistent_sqlite(2,13,3)
import Database.RawFilePath
openDb :: Annex ContentIdentifierHandle
openDb = do
dbdir <- calcRepo' gitAnnexContentIdentifierDbDir
- let db = dbdir P.</> "db"
- isnew <- liftIO $ not <$> R.doesPathExist db
+ let db = dbdir </> literalOsPath "db"
+ isnew <- liftIO $ not <$> doesDirectoryExist db
if isnew
then initDb db $ void $
runMigrationSilent migrateContentIdentifier
-- Migrate from old versions of database, which had buggy
-- and suboptimal uniqueness constraints.
#if MIN_VERSION_persistent_sqlite(2,13,3)
- else liftIO $ runSqlite' db $ void $
+ else liftIO $ runSqlite' (fromOsPath db) $ void $
runMigrationSilent migrateContentIdentifier
#else
else liftIO $ runSqlite (T.pack (fromRawFilePath db)) $ void $
import Git.Sha
import Git.FilePath
import qualified Git.DiffTree
-import qualified Utility.RawFilePath as R
import Database.Persist.Sql hiding (Key)
import Database.Persist.TH
-import qualified System.FilePath.ByteString as P
data ExportHandle = ExportHandle H.DbQueue UUID
openDb :: UUID -> Annex ExportHandle
openDb u = do
dbdir <- calcRepo' (gitAnnexExportDbDir u)
- let db = dbdir P.</> "db"
- unlessM (liftIO $ R.doesPathExist db) $ do
+ let db = dbdir </> literalOsPath "db"
+ unlessM (liftIO $ doesDirectoryExist db) $ do
initDb db $ void $
runMigrationSilent migrateExport
h <- liftIO $ H.openDbQueue db "exported"
addExportedLocation h k el = queueDb h $ do
void $ insertUniqueFast $ Exported k ef
let edirs = map
- (\ed -> ExportedDirectory (SByteString (fromExportDirectory ed)) ef)
+ (\ed -> ExportedDirectory (SByteString (fromOsPath (fromExportDirectory ed))) ef)
(exportDirectories el)
putMany edirs
where
- ef = SByteString (fromExportLocation el)
+ ef = SByteString (fromOsPath (fromExportLocation el))
removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
removeExportedLocation h k el = queueDb h $ do
deleteWhere [ExportedKey ==. k, ExportedFile ==. ef]
- let subdirs = map (SByteString . fromExportDirectory)
+ let subdirs = map
+ (SByteString . fromOsPath . fromExportDirectory)
(exportDirectories el)
deleteWhere [ExportedDirectoryFile ==. ef, ExportedDirectorySubdir <-. subdirs]
where
- ef = SByteString (fromExportLocation el)
+ ef = SByteString (fromOsPath (fromExportLocation el))
{- Note that this does not see recently queued changes. -}
getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation]
getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do
l <- selectList [ExportedKey ==. k] []
- return $ map (mkExportLocation . (\(SByteString f) -> f) . exportedFile . entityVal) l
+ return $ map (mkExportLocation . (\(SByteString f) -> toOsPath f) . exportedFile . entityVal) l
{- Note that this does not see recently queued changes. -}
isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool
l <- selectList [ExportedDirectorySubdir ==. ed] []
return $ null l
where
- ed = SByteString $ fromExportDirectory d
+ ed = SByteString $ fromOsPath $ fromExportDirectory d
{- Get locations in the export that might contain a key. -}
getExportTree :: ExportHandle -> Key -> IO [ExportLocation]
getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do
l <- selectList [ExportTreeKey ==. k] []
- return $ map (mkExportLocation . (\(SByteString f) -> f) . exportTreeFile . entityVal) l
+ return $ map (mkExportLocation . (\(SByteString f) -> toOsPath f) . exportTreeFile . entityVal) l
{- Get keys that might be currently exported to a location.
-
map (exportTreeKey . entityVal)
<$> selectList [ExportTreeFile ==. ef] []
where
- ef = SByteString (fromExportLocation el)
+ ef = SByteString (fromOsPath (fromExportLocation el))
addExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
addExportTree h k loc = queueDb h $
void $ insertUniqueFast $ ExportTree k ef
where
- ef = SByteString (fromExportLocation loc)
+ ef = SByteString (fromOsPath (fromExportLocation loc))
removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
removeExportTree h k loc = queueDb h $
deleteWhere [ExportTreeKey ==. k, ExportTreeFile ==. ef]
where
- ef = SByteString (fromExportLocation loc)
+ ef = SByteString (fromOsPath (fromExportLocation loc))
-- An action that is passed the old and new values that were exported,
-- and updates state.
import Utility.Exception
import Annex.Common
import Annex.LockFile
-import qualified Utility.RawFilePath as R
import Database.Persist.Sql hiding (Key)
import Database.Persist.TH
import Data.Time.Clock
-import qualified System.FilePath.ByteString as P
data FsckHandle = FsckHandle H.DbQueue UUID
go = do
removedb =<< calcRepo' (gitAnnexFsckDbDir u)
removedb =<< calcRepo' (gitAnnexFsckDbDirOld u)
- removedb = liftIO . void . tryIO . removeDirectoryRecursive . fromRawFilePath
+ removedb = liftIO . void . tryIO . removeDirectoryRecursive
{- Opens the database, creating it if it doesn't exist yet. -}
openDb :: UUID -> Annex FsckHandle
openDb u = do
dbdir <- calcRepo' (gitAnnexFsckDbDir u)
- let db = dbdir P.</> "db"
- unlessM (liftIO $ R.doesPathExist db) $ do
+ let db = dbdir </> literalOsPath "db"
+ unlessM (liftIO $ doesDirectoryExist db) $ do
initDb db $ void $
runMigrationSilent migrateFsck
lockFileCached =<< calcRepo' (gitAnnexFsckDbLock u)
import Utility.Debug
import Utility.DebugLocks
import Utility.InodeCache
+import Utility.OsPath
import Database.Persist.Sqlite
import qualified Database.Sqlite as Sqlite
{- A DbHandle is a reference to a worker thread that communicates with
- the database. It has a MVar which Jobs are submitted to.
- There is also an MVar which it will fill when there is a fatal error-}
-data DbHandle = DbHandle RawFilePath (Async ()) (MVar Job) (MVar String)
+data DbHandle = DbHandle OsPath (Async ()) (MVar Job) (MVar String)
{- Name of a table that should exist once the database is initialized. -}
type TableName = String
{- Opens the database, but does not perform any migrations. Only use
- once the database is known to exist and have the right tables. -}
-openDb :: RawFilePath -> TableName -> IO DbHandle
+openDb :: OsPath -> TableName -> IO DbHandle
openDb db tablename = do
jobs <- newEmptyMVar
errvar <- newEmptyMVar
| ChangeJob (SqlPersistM ())
| CloseJob
-workerThread :: RawFilePath -> TableName -> MVar Job -> MVar String -> IO ()
+workerThread :: OsPath -> TableName -> MVar Job -> MVar String -> IO ()
workerThread db tablename jobs errvar = newconn
where
newconn = do
- retrying only if the database shows signs of being modified by another
- process at least once each 30 seconds.
-}
-runSqliteRobustly :: TableName -> RawFilePath -> (SqlPersistM a) -> IO a
+runSqliteRobustly :: TableName -> OsPath -> (SqlPersistM a) -> IO a
runSqliteRobustly tablename db a = do
conn <- opensettle maxretries emptyDatabaseInodeCache
go conn maxretries emptyDatabaseInodeCache
opensettle retries ic = do
#if MIN_VERSION_persistent_sqlite(2,13,3)
- conn <- Sqlite.open' db
+ conn <- Sqlite.open' (fromOsPath db)
#else
- conn <- Sqlite.open (T.pack (fromRawFilePath db))
+ conn <- Sqlite.open (T.pack (fromOsPath db))
#endif
settle conn retries ic
, BaseBackend backend ~ SqlBackend
, BackendCompatible SqlBackend backend
)
- => RawFilePath
+ => OsPath
-> (LogFunc -> IO backend)
-> (backend -> m a)
-> m a
, BaseBackend backend ~ SqlBackend
, BackendCompatible SqlBackend backend
)
- => RawFilePath
+ => OsPath
-> backend
-> IO ()
closeRobustly db conn = go maxretries emptyDatabaseInodeCache
=> String
-> err
-> Int
- -> RawFilePath
+ -> OsPath
-> Int
-> DatabaseInodeCache
-> (Int -> DatabaseInodeCache -> IO a)
else giveup (databaseAccessStalledMsg action db err)
else a retries' ic
-databaseAccessStalledMsg :: Show err => String -> RawFilePath -> err -> String
+databaseAccessStalledMsg :: Show err => String -> OsPath -> err -> String
databaseAccessStalledMsg action db err =
- "Repeatedly unable to " ++ action ++ " sqlite database " ++ fromRawFilePath db
+ "Repeatedly unable to " ++ action ++ " sqlite database " ++ fromOsPath db
++ ": " ++ show err ++ ". "
++ "Perhaps another git-annex process is suspended and is "
++ "keeping this database locked?"
emptyDatabaseInodeCache :: DatabaseInodeCache
emptyDatabaseInodeCache = DatabaseInodeCache Nothing Nothing
-getDatabaseInodeCache :: RawFilePath -> IO DatabaseInodeCache
+getDatabaseInodeCache :: OsPath -> IO DatabaseInodeCache
getDatabaseInodeCache db = DatabaseInodeCache
<$> genInodeCache db noTSDelta
- <*> genInodeCache (db <> "-wal") noTSDelta
+ <*> genInodeCache (db <> literalOsPath "-wal") noTSDelta
isDatabaseModified :: DatabaseInodeCache -> DatabaseInodeCache -> Bool
isDatabaseModified (DatabaseInodeCache a1 b1) (DatabaseInodeCache a2 b2) =
import Types.MetaData
import Annex.MetaData.StandardFields
import Annex.LockFile
-import qualified Utility.RawFilePath as R
import Database.Persist.Sql hiding (Key)
import Database.Persist.TH
-import qualified System.FilePath.ByteString as P
import qualified Data.ByteString as B
import qualified Data.Set as S
openDb :: Annex ImportFeedDbHandle
openDb = do
dbdir <- calcRepo' gitAnnexImportFeedDbDir
- let db = dbdir P.</> "db"
- isnew <- liftIO $ not <$> R.doesPathExist db
+ let db = dbdir </> literalOsPath "db"
+ isnew <- liftIO $ not <$> doesDirectoryExist db
when isnew $
initDb db $ void $
runMigrationSilent migrateImportFeed
import Database.Persist.Sqlite
import Lens.Micro
import qualified Data.Text as T
-import qualified System.FilePath.ByteString as P
{- Ensures that the database is freshly initialized. Deletes any
- existing database. Pass the migration action for the database.
- file causes Sqlite to always use the same permissions for additional
- files it writes later on
-}
-initDb :: P.RawFilePath -> SqlPersistM () -> Annex ()
+initDb :: OsPath -> SqlPersistM () -> Annex ()
initDb db migration = do
- let dbdir = P.takeDirectory db
- let tmpdbdir = dbdir <> ".tmp"
- let tmpdb = tmpdbdir P.</> "db"
- let tmpdb' = T.pack (fromRawFilePath tmpdb)
+ let dbdir = takeDirectory db
+ let tmpdbdir = dbdir <> literalOsPath ".tmp"
+ let tmpdb = tmpdbdir </> literalOsPath "db"
+ let tmpdb' = fromOsPath tmpdb
createAnnexDirectory tmpdbdir
#if MIN_VERSION_persistent_sqlite(2,13,3)
- liftIO $ runSqliteInfo' tmpdb (enableWAL tmpdb') migration
+ liftIO $ runSqliteInfo' tmpdb' (enableWAL tmpdb') migration
#else
liftIO $ runSqliteInfo (enableWAL tmpdb') migration
#endif
setAnnexDirPerm tmpdbdir
-- Work around sqlite bug that prevents it from honoring
-- less restrictive umasks.
- liftIO $ R.setFileMode tmpdb =<< defaultFileMode
+ liftIO $ R.setFileMode tmpdb' =<< defaultFileMode
setAnnexFilePerm tmpdb
liftIO $ do
- void $ tryIO $ removeDirectoryRecursive (fromRawFilePath dbdir)
- R.rename tmpdbdir dbdir
+ void $ tryIO $ removeDirectoryRecursive dbdir
+ R.rename (fromOsPath tmpdbdir) (fromOsPath dbdir)
{- Make sure that the database uses WAL mode, to prevent readers
- from blocking writers, and prevent a writer from blocking readers.
-
- Note that once WAL mode is enabled, it will persist whenever the
- database is opened. -}
-enableWAL :: T.Text -> SqliteConnectionInfo
+enableWAL :: RawFilePath -> SqliteConnectionInfo
enableWAL db = over walEnabled (const True) $
- mkSqliteConnectionInfo db
+ mkSqliteConnectionInfo (T.pack (fromRawFilePath db))
import qualified Git.Ref
import Config
import Config.Smudge
-import qualified Utility.RawFilePath as R
+import qualified Utility.OsString as OS
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
-import qualified System.FilePath.ByteString as P
import Control.Concurrent.Async
{- Runs an action that reads from the database.
lck <- calcRepo' gitAnnexKeysDbLock
catchPermissionDenied permerr $ withExclusiveLock lck $ do
dbdir <- calcRepo' gitAnnexKeysDbDir
- let db = dbdir P.</> "db"
- dbexists <- liftIO $ R.doesPathExist db
+ let db = dbdir </> literalOsPath "db"
+ dbexists <- liftIO $ doesDirectoryExist db
case dbexists of
True -> open db False
False -> do
)
{- Include a known associated file along with any recorded in the database. -}
-getAssociatedFilesIncluding :: AssociatedFile -> Key -> Annex [RawFilePath]
+getAssociatedFilesIncluding :: AssociatedFile -> Key -> Annex [OsPath]
getAssociatedFilesIncluding afile k = emptyWhenBare $ do
g <- Annex.gitRepo
l <- map (`fromTopFilePath` g) <$> getAssociatedFiles k
SQL.removeAssociatedFile k
{- Stats the files, and stores their InodeCaches. -}
-storeInodeCaches :: Key -> [RawFilePath] -> Annex ()
+storeInodeCaches :: Key -> [OsPath] -> Annex ()
storeInodeCaches k fs = withTSDelta $ \d ->
addInodeCaches k . catMaybes
=<< liftIO (mapM (\f -> genInodeCache f d) fs)
( return mempty
, do
gitindex <- inRepo currentIndexFile
- indexcache <- fromRawFilePath <$> calcRepo' gitAnnexKeysDbIndexCache
+ indexcache <- fromOsPath <$> calcRepo' gitAnnexKeysDbIndexCache
withTSDelta (liftIO . genInodeCache gitindex) >>= \case
Just cur -> readindexcache indexcache >>= \case
Nothing -> go cur indexcache =<< getindextree
-- be a pointer file. And a pointer file that is replaced with
-- a non-pointer file will match this. This is only a
-- prefilter so that's ok.
- , Param $ "-G" ++ fromRawFilePath (toInternalGitPath $
- P.pathSeparator `S.cons` objectDir)
+ , Param $ "-G" ++
+ fromOsPath (toInternalGitPath $
+ pathSeparator `OS.cons` objectDir)
-- Disable rename detection.
, Param "--no-renames"
-- Avoid other complications.
procdiff mdfeeder (info:file:rest) conflicted
| ":" `S.isPrefixOf` info = case S8.words info of
(_colonsrcmode:dstmode:srcsha:dstsha:status:[]) -> do
+ let file' = asTopFilePath (toOsPath file)
let conflicted' = status == "U"
-- avoid removing associated file when
-- there is a merge conflict
send mdfeeder (Ref srcsha) $ \case
Just oldkey -> do
liftIO $ SQL.removeAssociatedFile oldkey
- (asTopFilePath file)
- (SQL.WriteHandle qh)
+ file' (SQL.WriteHandle qh)
return True
Nothing -> return False
send mdfeeder (Ref dstsha) $ \case
Just key -> do
liftIO $ addassociatedfile key
- (asTopFilePath file)
- (SQL.WriteHandle qh)
+ file' (SQL.WriteHandle qh)
when (dstmode /= fmtTreeItemType TreeSymlink) $
- reconcilepointerfile (asTopFilePath file) key
+ reconcilepointerfile file' key
return True
Nothing -> return False
procdiff mdfeeder rest
procmergeconflictdiff mdfeeder (info:file:rest) conflicted
| ":" `S.isPrefixOf` info = case S8.words info of
(_colonmode:_mode:sha:_sha:status:[]) -> do
+ let file' = asTopFilePath (toOsPath file)
send mdfeeder (Ref sha) $ \case
Just key -> do
liftIO $ SQL.addAssociatedFile key
- (asTopFilePath file)
- (SQL.WriteHandle qh)
+ file' (SQL.WriteHandle qh)
return True
Nothing -> return False
let conflicted' = status == "U"
import qualified Database.Queue as H
import Utility.InodeCache
import Git.FilePath
+import Utility.OsPath
import Database.Persist.Sql hiding (Key)
import Database.Persist.TH
(Associated k af)
[AssociatedFile =. af, AssociatedKey =. k]
where
- af = SByteString (getTopFilePath f)
+ af = SByteString (fromOsPath (getTopFilePath f))
-- Faster than addAssociatedFile, but only safe to use when the file
-- was not associated with a different key before, as it does not delete
newAssociatedFile k f = queueDb $
insert_ $ Associated k af
where
- af = SByteString (getTopFilePath f)
+ af = SByteString (fromOsPath (getTopFilePath f))
{- Note that the files returned were once associated with the key, but
- some of them may not be any longer. -}
getAssociatedFiles :: Key -> ReadHandle -> IO [TopFilePath]
getAssociatedFiles k = readDb $ do
l <- selectList [AssociatedKey ==. k] []
- return $ map (asTopFilePath . (\(SByteString f) -> f) . associatedFile . entityVal) l
+ return $ map (asTopFilePath . toOsPath . (\(SByteString f) -> f) . associatedFile . entityVal) l
{- Gets any keys that are on record as having a particular associated file.
- (Should be one or none.) -}
l <- selectList [AssociatedFile ==. af] []
return $ map (associatedKey . entityVal) l
where
- af = SByteString (getTopFilePath f)
+ af = SByteString (fromOsPath (getTopFilePath f))
removeAssociatedFile :: Key -> TopFilePath -> WriteHandle -> IO ()
removeAssociatedFile k f = queueDb $
deleteWhere [AssociatedKey ==. k, AssociatedFile ==. af]
where
- af = SByteString (getTopFilePath f)
+ af = SByteString (fromOsPath (getTopFilePath f))
addInodeCaches :: Key -> [InodeCache] -> WriteHandle -> IO ()
addInodeCaches k is = queueDb $
) where
import Utility.Monad
-import Utility.RawFilePath
import Utility.DebugLocks
import Utility.Exception
+import Utility.OsPath
import Database.Handle
import Database.Persist.Sqlite
{- Opens the database queue, but does not perform any migrations. Only use
- if the database is known to exist and have the right tables; ie after
- running initDb. -}
-openDbQueue :: RawFilePath -> TableName -> IO DbQueue
+openDbQueue :: OsPath -> TableName -> IO DbQueue
openDbQueue db tablename = DQ
<$> openDb db tablename
<*> (newMVar =<< emptyQueue)
import Database.Types
import Annex.LockFile
import Git.Types
-import qualified Utility.RawFilePath as R
import Database.Persist.Sql hiding (Key)
import Database.Persist.TH
-import qualified System.FilePath.ByteString as P
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Control.Exception
openDb :: Annex RepoSizeHandle
openDb = lockDbWhile permerr $ do
dbdir <- calcRepo' gitAnnexRepoSizeDbDir
- let db = dbdir P.</> "db"
- unlessM (liftIO $ R.doesPathExist db) $ do
+ let db = dbdir </> literalOsPath "db"
+ unlessM (liftIO $ doesDirectoryExist db) $ do
initDb db $ void $
runMigrationSilent migrateRepoSizes
h <- liftIO $ H.openDb db "repo_sizes"
relPath,
) where
-import qualified Data.ByteString as B
import Network.URI (uriPath, uriScheme, unEscapeString)
#ifndef mingw32_HOST_OS
import System.Posix.Files
#endif
-import qualified System.FilePath.ByteString as P
import Common
import Git.Types
+import qualified Utility.OsString as OS
#ifndef mingw32_HOST_OS
import Utility.FileMode
#endif
repoDescribe Repo { remoteName = Just name } = name
repoDescribe Repo { location = Url url } = show url
repoDescribe Repo { location = UnparseableUrl url } = url
-repoDescribe Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir
-repoDescribe Repo { location = Local { gitdir = dir } } = fromRawFilePath dir
-repoDescribe Repo { location = LocalUnknown dir } = fromRawFilePath dir
+repoDescribe Repo { location = Local { worktree = Just dir } } = fromOsPath dir
+repoDescribe Repo { location = Local { gitdir = dir } } = fromOsPath dir
+repoDescribe Repo { location = LocalUnknown dir } = fromOsPath dir
repoDescribe Repo { location = Unknown } = "UNKNOWN"
{- Location of the repo, either as a path or url. -}
repoLocation :: Repo -> String
repoLocation Repo { location = Url url } = show url
repoLocation Repo { location = UnparseableUrl url } = url
-repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir
-repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir
-repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir
+repoLocation Repo { location = Local { worktree = Just dir } } = fromOsPath dir
+repoLocation Repo { location = Local { gitdir = dir } } = fromOsPath dir
+repoLocation Repo { location = LocalUnknown dir } = fromOsPath dir
repoLocation Repo { location = Unknown } = giveup "unknown repoLocation"
{- Path to a repository. For non-bare, this is the worktree, for bare,
- it's the gitdir, and for URL repositories, is the path on the remote
- host. -}
-repoPath :: Repo -> RawFilePath
-repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u
+repoPath :: Repo -> OsPath
+repoPath Repo { location = Url u } = toOsPath $ unEscapeString $ uriPath u
repoPath Repo { location = Local { worktree = Just d } } = d
repoPath Repo { location = Local { gitdir = d } } = d
repoPath Repo { location = LocalUnknown dir } = dir
repoPath Repo { location = Unknown } = giveup "unknown repoPath"
repoPath Repo { location = UnparseableUrl _u } = giveup "unknown repoPath"
-repoWorkTree :: Repo -> Maybe RawFilePath
+repoWorkTree :: Repo -> Maybe OsPath
repoWorkTree Repo { location = Local { worktree = Just d } } = Just d
repoWorkTree _ = Nothing
{- Path to a local repository's .git directory. -}
-localGitDir :: Repo -> RawFilePath
+localGitDir :: Repo -> OsPath
localGitDir Repo { location = Local { gitdir = d } } = d
localGitDir _ = giveup "unknown localGitDir"
| otherwise = action
{- Path to a repository's gitattributes file. -}
-attributes :: Repo -> RawFilePath
+attributes :: Repo -> OsPath
attributes repo
| repoIsLocalBare repo = attributesLocal repo
- | otherwise = repoPath repo P.</> ".gitattributes"
+ | otherwise = repoPath repo </> literalOsPath ".gitattributes"
-attributesLocal :: Repo -> RawFilePath
-attributesLocal repo = localGitDir repo P.</> "info" P.</> "attributes"
+attributesLocal :: Repo -> OsPath
+attributesLocal repo = localGitDir repo </> literalOsPath "info" </> literalOsPath "attributes"
{- Path to a given hook script in a repository, only if the hook exists
- and is executable. -}
-hookPath :: String -> Repo -> IO (Maybe FilePath)
+hookPath :: String -> Repo -> IO (Maybe OsPath)
hookPath script repo = do
- let hook = fromRawFilePath (localGitDir repo) </> "hooks" </> script
+ let hook = localGitDir repo </> literalOsPath "hooks" </> toOsPath script
ifM (catchBoolIO $ isexecutable hook)
( return $ Just hook , return Nothing )
where
#if mingw32_HOST_OS
isexecutable f = doesFileExist f
#else
- isexecutable f = isExecutable . fileMode <$> getSymbolicLinkStatus f
+ isexecutable f = isExecutable . fileMode
+ <$> getSymbolicLinkStatus (fromOsPath f)
#endif
{- Makes the path to a local Repo be relative to the cwd. -}
where
torel p = do
p' <- relPathCwdToFile p
- return $ if B.null p' then "." else p'
+ return $ if OS.null p'
+ then literalOsPath "."
+ else p'
{- Adjusts the path to a local Repo using the provided function. -}
-adjustPath :: (RawFilePath -> IO RawFilePath) -> Repo -> IO Repo
+adjustPath :: (OsPath -> IO OsPath) -> Repo -> IO Repo
adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do
d' <- f d
w' <- maybe (pure Nothing) (Just <$$> f) w
catFileMetaDataStop = CoProcess.stop . checkFileProcess
{- Reads a file from a specified branch. -}
-catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString
+catFile :: CatFileHandle -> Branch -> OsPath -> IO L.ByteString
catFile h branch file = catObject h $
Git.Ref.branchFileRef branch file
-catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))
+catFileDetails :: CatFileHandle -> Branch -> OsPath -> IO (Maybe (L.ByteString, Sha, ObjectType))
catFileDetails h branch file = catObjectDetails h $
Git.Ref.branchFileRef branch file
import Git
import Git.Command
import qualified Utility.CoProcess as CoProcess
-import qualified Utility.RawFilePath as R
import System.IO.Error
import qualified Data.ByteString as B
-type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], RawFilePath)
+type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], OsPath)
type Attr = String
- and returns a handle. -}
checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle
checkAttrStart attrs repo = do
- currdir <- R.getCurrentDirectory
+ currdir <- getCurrentDirectory
h <- gitCoProcessStart True params repo
return (h, attrs, currdir)
where
checkAttrStop :: CheckAttrHandle -> IO ()
checkAttrStop (h, _, _) = CoProcess.stop h
-checkAttr :: CheckAttrHandle -> Attr -> RawFilePath -> IO String
+checkAttr :: CheckAttrHandle -> Attr -> OsPath -> IO String
checkAttr h want file = checkAttrs h [want] file >>= return . \case
(v:_) -> v
[] -> ""
{- Gets attributes of a file. When an attribute is not specified,
- returns "" for it. -}
-checkAttrs :: CheckAttrHandle -> [Attr] -> RawFilePath -> IO [String]
+checkAttrs :: CheckAttrHandle -> [Attr] -> OsPath -> IO [String]
checkAttrs (h, attrs, currdir) want file = do
l <- CoProcess.query h send (receive "")
return (getvals l want)
getvals l (x:xs) = case map snd $ filter (\(attr, _) -> attr == x) l of
["unspecified"] -> "" : getvals l xs
[v] -> v : getvals l xs
- _ -> giveup $ "unable to determine " ++ x ++ " attribute of " ++ fromRawFilePath file
+ _ -> giveup $ "unable to determine " ++ x ++ " attribute of " ++ fromOsPath file
- send to = B.hPutStr to $ file' `B.snoc` 0
+ send to = B.hPutStr to $ (fromOsPath file') `B.snoc` 0
receive c from = do
s <- hGetSomeString from 1024
if null s
checkIgnoreStop = void . tryIO . CoProcess.stop
{- Returns True if a file is ignored. -}
-checkIgnored :: CheckIgnoreHandle -> RawFilePath -> IO Bool
+checkIgnored :: CheckIgnoreHandle -> OsPath -> IO Bool
checkIgnored h file = CoProcess.query h send (receive "")
where
send to = do
- B.hPutStr to $ file `B.snoc` 0
+ B.hPutStr to $ fromOsPath file `B.snoc` 0
hFlush to
receive c from = do
s <- hGetSomeString from 1024
parse s = case segment (== '\0') s of
(_source:_line:pattern:_pathname:_eol:[]) -> Just $ not $ null pattern
_ -> Nothing
- eofError = ioError $ mkIOError userErrorType "git cat-file EOF" Nothing Nothing
+ eofError = ioError $ mkIOError userErrorType "git check-ignore EOF" Nothing Nothing
where
setdir
| gitEnvOverridesGitDir r = []
- | otherwise = [Param $ "--git-dir=" ++ fromRawFilePath (gitdir l)]
+ | otherwise = [Param $ "--git-dir=" ++ fromOsPath (gitdir l)]
settree = case worktree l of
Nothing -> []
- Just t -> [Param $ "--work-tree=" ++ fromRawFilePath t]
+ Just t -> [Param $ "--work-tree=" ++ fromOsPath t]
gitCommandLine _ repo = assertLocal repo $ error "internal"
{- Runs git in the specified repo. -}
- convenience.
-}
pipeNullSplit' :: [CommandParam] -> Repo -> IO ([S.ByteString], IO Bool)
-pipeNullSplit' params repo = do
+pipeNullSplit' = pipeNullSplit'' id
+
+pipeNullSplit'' :: (S.ByteString -> t) -> [CommandParam] -> Repo -> IO ([t], IO Bool)
+pipeNullSplit'' f params repo = do
(s, cleanup) <- pipeNullSplit params repo
- return (map L.toStrict s, cleanup)
+ return (map (f . L.toStrict) s, cleanup)
pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [S.ByteString]
pipeNullSplitStrict params repo = do
import qualified Data.ByteString.Char8 as S8
import qualified Data.List.NonEmpty as NE
import Data.Char
-import qualified System.FilePath.ByteString as P
import Control.Concurrent.Async
import Common
params = addparams ++ explicitrepoparams
++ ["config", "--null", "--list"]
p = (proc "git" params)
- { cwd = Just (fromRawFilePath d)
+ { cwd = Just (fromOsPath d)
, env = gitEnv repo
, std_out = CreatePipe
}
global :: IO (Maybe Repo)
global = do
home <- myHomeDir
- ifM (doesFileExist $ home </> ".gitconfig")
+ ifM (doesFileExist $ toOsPath home </> literalOsPath ".gitconfig")
( Just <$> withCreateProcess p go
, return Nothing
)
-}
updateLocation :: Repo -> IO Repo
updateLocation r@(Repo { location = LocalUnknown d }) = case isBare r of
- Just True -> ifM (doesDirectoryExist (fromRawFilePath dotgit))
+ Just True -> ifM (doesDirectoryExist dotgit)
( updateLocation' r $ Local dotgit Nothing
, updateLocation' r $ Local d Nothing
)
Just False -> mknonbare
{- core.bare not in config, probably because safe.directory
- did not allow reading the config -}
- Nothing -> ifM (Git.Construct.isBareRepo (fromRawFilePath d))
+ Nothing -> ifM (Git.Construct.isBareRepo d)
( mkbare
, mknonbare
)
where
- dotgit = d P.</> ".git"
+ dotgit = d </> literalOsPath ".git"
-- git treats eg ~/foo as a bare git repository located in
-- ~/foo/.git if ~/foo/.git/config has core.bare=true
- mkbare = ifM (doesDirectoryExist (fromRawFilePath dotgit))
+ mkbare = ifM (doesDirectoryExist dotgit)
( updateLocation' r $ Local dotgit Nothing
, updateLocation' r $ Local d Nothing
)
Just (ConfigValue d) -> do
{- core.worktree is relative to the gitdir -}
top <- absPath (gitdir l)
- let p = absPathFrom top d
+ let p = absPathFrom top (toOsPath d)
return $ l { worktree = Just p }
Just NoConfigValue -> return l
return $ r { location = l' }
-- Cannot use gitCommandLine here because specifying --git-dir
-- will bypass the git security check.
let p = (proc "git" ["config", "--local", "--list"])
- { cwd = Just (fromRawFilePath (repoPath r))
+ { cwd = Just (fromOsPath (repoPath r))
, env = gitEnv r
}
(out, ok) <- processTranscript' p Nothing
import Utility.UserInfo
import Utility.Url.Parse
import qualified Utility.RawFilePath as R
-
-import qualified Data.ByteString as B
-import qualified System.FilePath.ByteString as P
+import qualified Utility.OsString as OS
{- Finds the git repository used for the cwd, which may be in a parent
- directory. -}
fromCwd :: IO (Maybe Repo)
-fromCwd = R.getCurrentDirectory >>= seekUp
+fromCwd = R.getCurrentDirectory >>= seekUp . toOsPath
where
seekUp dir = do
r <- checkForRepo dir
Just loc -> pure $ Just $ newFrom loc
{- Local Repo constructor, accepts a relative or absolute path. -}
-fromPath :: RawFilePath -> IO Repo
+fromPath :: OsPath -> IO Repo
fromPath dir
-- When dir == "foo/.git", git looks for "foo/.git/.git",
-- and failing that, uses "foo" as the repository.
- | (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir =
- ifM (doesDirectoryExist $ fromRawFilePath dir </> ".git")
+ | (pathSeparator `OS.cons` dotgit) `OS.isSuffixOf` canondir =
+ ifM (doesDirectoryExist $ dir </> dotgit)
( ret dir
- , ret (P.takeDirectory canondir)
+ , ret (takeDirectory canondir)
)
- | otherwise = ifM (doesDirectoryExist (fromRawFilePath dir))
+ | otherwise = ifM (doesDirectoryExist dir)
( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom)
-- git falls back to dir.git when dir doesn't
-- exist, as long as dir didn't end with a
-- path separator
, if dir == canondir
- then ret (dir <> ".git")
+ then ret (dir <> dotgit)
else ret dir
)
where
+ dotgit = literalOsPath ".git"
ret = pure . newFrom . LocalUnknown
- canondir = P.dropTrailingPathSeparator dir
+ canondir = dropTrailingPathSeparator dir
{- Local Repo constructor, requires an absolute path to the repo be
- specified. -}
-fromAbsPath :: RawFilePath -> IO Repo
+fromAbsPath :: OsPath -> IO Repo
fromAbsPath dir
| absoluteGitPath dir = fromPath dir
| otherwise =
fromUrl' :: String -> IO Repo
fromUrl' url
| "file://" `isPrefixOf` url = case parseURIPortable url of
- Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u
+ Just u -> fromAbsPath $ toOsPath $ unEscapeString $ uriPath u
Nothing -> pure $ newFrom $ UnparseableUrl url
| otherwise = case parseURIPortable url of
Just u -> pure $ newFrom $ Url u
[ s
, "//"
, auth
- , fromRawFilePath (repoPath r)
+ , fromOsPath (repoPath r)
]
in r { location = Url $ fromJust $ parseURIPortable absurl }
_ -> r
fromRemotePath :: FilePath -> Repo -> IO Repo
fromRemotePath dir repo = do
dir' <- expandTilde dir
- fromPath $ repoPath repo P.</> toRawFilePath dir'
+ fromPath $ repoPath repo </> dir'
{- Git remotes can have a directory that is specified relative
- to the user's home directory, or that contains tilde expansions.
- This converts such a directory to an absolute path.
- Note that it has to run on the system where the remote is.
-}
-repoAbsPath :: RawFilePath -> IO RawFilePath
+repoAbsPath :: OsPath -> IO OsPath
repoAbsPath d = do
- d' <- expandTilde (fromRawFilePath d)
+ d' <- expandTilde (fromOsPath d)
h <- myHomeDir
- return $ toRawFilePath $ h </> d'
+ return $ toOsPath h </> d'
-expandTilde :: FilePath -> IO FilePath
+expandTilde :: FilePath -> IO OsPath
#ifdef mingw32_HOST_OS
-expandTilde = return
+expandTilde = return . toOsPath
#else
expandTilde p = expandt True p
-- If unable to expand a tilde, eg due to a user not existing,
-- use the path as given.
- `catchNonAsync` (const (return p))
+ `catchNonAsync` (const (return (toOsPath p)))
where
- expandt _ [] = return ""
+ expandt _ [] = return $ literalOsPath ""
expandt _ ('/':cs) = do
v <- expandt True cs
- return ('/':v)
+ return $ literalOsPath "/" <> v
expandt True ('~':'/':cs) = do
h <- myHomeDir
- return $ h </> cs
- expandt True "~" = myHomeDir
+ return $ toOsPath h </> toOsPath cs
+ expandt True "~" = toOsPath <$> myHomeDir
expandt True ('~':cs) = do
let (name, rest) = findname "" cs
u <- getUserEntryForName name
- return $ homeDirectory u </> rest
+ return $ toOsPath (homeDirectory u) </> toOsPath rest
expandt _ (c:cs) = do
v <- expandt False cs
- return (c:v)
+ return $ toOsPath [c] <> v
findname n [] = (n, "")
findname n (c:cs)
| c == '/' = (n, cs)
{- Checks if a git repository exists in a directory. Does not find
- git repositories in parent directories. -}
-checkForRepo :: RawFilePath -> IO (Maybe RepoLocation)
+checkForRepo :: OsPath -> IO (Maybe RepoLocation)
checkForRepo dir =
check isRepo $
check (checkGitDirFile dir) $
- check (checkdir (isBareRepo dir')) $
+ check (checkdir (isBareRepo dir)) $
return Nothing
where
check test cont = maybe cont (return . Just) =<< test
, return Nothing
)
isRepo = checkdir $
- doesFileExist (dir' </> ".git" </> "config")
+ doesFileExist (dir </> literalOsPath ".git" </> literalOsPath "config")
<||>
-- A git-worktree lacks .git/config, but has .git/gitdir.
-- (Normally the .git is a file, not a symlink, but it can
-- be converted to a symlink and git will still work;
-- this handles that case.)
- doesFileExist (dir' </> ".git" </> "gitdir")
- dir' = fromRawFilePath dir
+ doesFileExist (dir </> literalOsPath ".git" </> literalOsPath "gitdir")
-isBareRepo :: FilePath -> IO Bool
-isBareRepo dir = doesFileExist (dir </> "config")
- <&&> doesDirectoryExist (dir </> "objects")
+isBareRepo :: OsPath -> IO Bool
+isBareRepo dir = doesFileExist (dir </> literalOsPath "config")
+ <&&> doesDirectoryExist (dir </> literalOsPath "objects")
-- Check for a .git file.
-checkGitDirFile :: RawFilePath -> IO (Maybe RepoLocation)
+checkGitDirFile :: OsPath -> IO (Maybe RepoLocation)
checkGitDirFile dir = adjustGitDirFile' $ Local
- { gitdir = dir P.</> ".git"
+ { gitdir = dir </> literalOsPath ".git"
, worktree = Just dir
}
adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation)
adjustGitDirFile' loc@(Local {}) = do
let gd = gitdir loc
- c <- firstLine <$> catchDefaultIO "" (readFile (fromRawFilePath gd))
+ c <- firstLine <$> catchDefaultIO "" (readFile (fromOsPath gd))
if gitdirprefix `isPrefixOf` c
then do
- top <- fromRawFilePath . P.takeDirectory <$> absPath gd
+ top <- takeDirectory <$> absPath gd
return $ Just $ loc
- { gitdir = absPathFrom
- (toRawFilePath top)
- (toRawFilePath
- (drop (length gitdirprefix) c))
+ { gitdir = absPathFrom top $
+ toOsPath $ drop (length gitdirprefix) c
}
else return Nothing
where
import qualified Git.Config
import Utility.Env
import Utility.Env.Set
-import qualified Utility.RawFilePath as R
import qualified Data.ByteString as B
-import qualified System.FilePath.ByteString as P
{- Gets the current git repository.
-
get :: IO Repo
get = do
gd <- getpathenv "GIT_DIR"
- r <- configure gd =<< fromCwd
+ r <- configure (fmap toOsPath gd) =<< fromCwd
prefix <- getpathenv "GIT_PREFIX"
wt <- maybe (worktree (location r)) Just
<$> getpathenvprefix "GIT_WORK_TREE" prefix
case wt of
Nothing -> relPath r
Just d -> do
- curr <- R.getCurrentDirectory
+ curr <- getCurrentDirectory
unless (d `dirContains` curr) $
- setCurrentDirectory (fromRawFilePath d)
+ setCurrentDirectory d
relPath $ addworktree wt r
where
getpathenv s = do
getpathenv s >>= \case
Nothing -> return Nothing
Just d
- | d == "." -> return (Just d)
+ | d == "." -> return (Just (toOsPath d))
| otherwise -> Just
- <$> absPath (prefix P.</> d)
- getpathenvprefix s _ = getpathenv s
+ <$> absPath (toOsPath prefix </> toOsPath d)
+ getpathenvprefix s _ = fmap toOsPath <$> getpathenv s
configure Nothing (Just r) = Git.Config.read r
configure (Just d) _ = do
absd <- absPath d
- curr <- R.getCurrentDirectory
+ curr <- getCurrentDirectory
loc <- adjustGitDirFile $ Local
{ gitdir = absd
, worktree = Just curr
parseDiffRaw,
) where
-import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Attoparsec.ByteString.Lazy as A
import qualified Data.Attoparsec.ByteString.Char8 as A8
import Git.DiffTreeItem
import qualified Git.Quote
import qualified Git.Ref
+import qualified Utility.OsString as OS
import Utility.Attoparsec
{- Checks if the DiffTreeItem modifies a file with a given name
isDiffOf :: DiffTreeItem -> TopFilePath -> Bool
isDiffOf diff f =
let f' = getTopFilePath f
- in if B.null f'
+ in if OS.null f'
then True -- top of repo contains all
else f' `dirContains` getTopFilePath (file diff)
<*> (maybe (fail "bad dstsha") return . extractSha =<< nextword)
<* A8.char ' '
<*> A.takeByteString
- <*> pure (asTopFilePath $ fromInternalGitPath $ Git.Quote.unquote f)
+ <*> pure (asTopFilePath $ fromInternalGitPath $ toOsPath $ Git.Quote.unquote f)
where
nextword = A8.takeTill (== ' ')
- and a copy of the rest of the system environment. -}
propGitEnv :: Repo -> IO [(String, String)]
propGitEnv g = do
- g' <- addGitEnv g "GIT_DIR" (fromRawFilePath (localGitDir g))
+ g' <- addGitEnv g "GIT_DIR" (fromOsPath (localGitDir g))
g'' <- maybe (pure g')
- (addGitEnv g' "GIT_WORK_TREE" . fromRawFilePath)
+ (addGitEnv g' "GIT_WORK_TREE" . fromOsPath)
(repoWorkTree g)
return $ fromMaybe [] (gitEnv g'')
import Git
import Git.Quote
-import qualified System.FilePath.ByteString as P
-import qualified System.FilePath.Posix.ByteString
import GHC.Generics
import Control.DeepSeq
-{- A RawFilePath, relative to the top of the git repository. -}
-newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath }
+{- A path relative to the top of the git repository. -}
+newtype TopFilePath = TopFilePath { getTopFilePath :: OsPath }
deriving (Show, Eq, Ord, Generic)
instance NFData TopFilePath
UnquotedByteString (fromRef' b) <> ":" <> QuotedPath (getTopFilePath f)
{- Path to a TopFilePath, within the provided git repo. -}
-fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath
-fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p)
+fromTopFilePath :: TopFilePath -> Git.Repo -> OsPath
+fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p)
{- The input FilePath can be absolute, or relative to the CWD. -}
-toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath
+toTopFilePath :: OsPath -> Git.Repo -> IO TopFilePath
toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file
{- The input RawFilePath must already be relative to the top of the git
- repository -}
-asTopFilePath :: RawFilePath -> TopFilePath
+asTopFilePath :: OsPath -> TopFilePath
asTopFilePath file = TopFilePath file
{- Git may use a different representation of a path when storing
- despite Windows using '\'.
-
-}
-type InternalGitPath = RawFilePath
+type InternalGitPath = OsPath
-toInternalGitPath :: RawFilePath -> InternalGitPath
+toInternalGitPath :: OsPath -> InternalGitPath
#ifndef mingw32_HOST_OS
toInternalGitPath = id
#else
-toInternalGitPath = encodeBS . replace "\\" "/" . decodeBS
+toInternalGitPath = toOsPath . encodeBS . replace "\\" "/" . decodeBS . fromOsPath
#endif
-fromInternalGitPath :: InternalGitPath -> RawFilePath
+fromInternalGitPath :: InternalGitPath -> OsPath
#ifndef mingw32_HOST_OS
fromInternalGitPath = id
#else
-fromInternalGitPath = encodeBS . replace "/" "\\" . decodeBS
+fromInternalGitPath = toOsPath . encodeBS . replace "/" "\\" . decodeBS . fromOsPath
#endif
{- isAbsolute on Windows does not think "/foo" or "\foo" is absolute,
- so try posix paths.
-}
-absoluteGitPath :: RawFilePath -> Bool
-absoluteGitPath p = P.isAbsolute p ||
- System.FilePath.Posix.ByteString.isAbsolute (toInternalGitPath p)
+absoluteGitPath :: OsPath -> Bool
+absoluteGitPath p = isAbsolute p || isAbsolute (toInternalGitPath p)
-- Delay capability is not implemented, so filter it out.
filtercapabilities = filter (`elem` [Capability "smudge", Capability "clean"])
-data FilterRequest = Smudge FilePath | Clean FilePath
+data FilterRequest = Smudge OsPath | Clean OsPath
deriving (Show, Eq)
{- Waits for the next FilterRequest to be received. Does not read
let cs = mapMaybe decodeConfigValue ps
case (extractConfigValue cs "command", extractConfigValue cs "pathname") of
(Just command, Just pathname)
- | command == "smudge" -> return $ Just $ Smudge pathname
- | command == "clean" -> return $ Just $ Clean pathname
+ | command == "smudge" -> return $ Just $ Smudge $ toOsPath pathname
+ | command == "clean" -> return $ Just $ Clean $ toOsPath pathname
| otherwise -> return Nothing
_ -> return Nothing
- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Git.HashObject where
import Git.Sha
import Git.Command
import Git.Types
-import qualified Utility.CoProcess as CoProcess
import Utility.Tmp
+import qualified Utility.CoProcess as CoProcess
+import qualified Utility.OsString as OS
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Builder
-import Data.Char
data HashObjectHandle = HashObjectHandle CoProcess.CoProcessHandle Repo [CommandParam]
hashObjectStop (HashObjectHandle h _ _) = CoProcess.stop h
{- Injects a file into git, returning the Sha of the object. -}
-hashFile :: HashObjectHandle -> RawFilePath -> IO Sha
+hashFile :: HashObjectHandle -> OsPath -> IO Sha
hashFile hdl@(HashObjectHandle h _ _) file = do
-- git hash-object chdirs to the top of the repository on
-- start, so if the filename is relative, it will
-- So, make the filename absolute, which will work now
-- and also if git's behavior later changes.
file' <- absPath file
- if newline `S.elem` file' || carriagereturn `S.elem` file
+ if newline `OS.elem` file' || carriagereturn `OS.elem` file
then hashFile' hdl file
- else CoProcess.query h (send file') receive
+ else CoProcess.query h (send (fromOsPath file')) receive
where
send file' to = S8.hPutStrLn to file'
receive from = getSha "hash-object" $ S8.hGetLine from
- newline = fromIntegral (ord '\n')
+ newline = unsafeFromChar '\n'
-- git strips carriage return from the end of a line, out of some
-- misplaced desire to support windows, so also use the newline
-- fallback for those.
- carriagereturn = fromIntegral (ord '\r')
+ carriagereturn = unsafeFromChar '\r'
{- Runs git hash-object once per call, rather than using a running
- one, so is slower. But, is able to handle newlines in the filepath,
- which --stdin-paths cannot. -}
-hashFile' :: HashObjectHandle -> RawFilePath -> IO Sha
+hashFile' :: HashObjectHandle -> OsPath -> IO Sha
hashFile' (HashObjectHandle _ repo ps) file = getSha "hash-object" $
- pipeReadStrict (ps ++ [File (fromRawFilePath file)]) repo
+ pipeReadStrict (ps ++ [File (fromOsPath file)]) repo
class HashableBlob t where
hashableBlobToHandle :: Handle -> t -> IO ()
{- Injects a blob into git. Unfortunately, the current git-hash-object
- interface does not allow batch hashing without using temp files. -}
hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha
-hashBlob h b = withTmpFile (toOsPath "hash") $ \tmp tmph -> do
+hashBlob h b = withTmpFile (literalOsPath "hash") $ \tmp tmph -> do
hashableBlobToHandle tmph b
hClose tmph
- hashFile h (fromOsPath tmp)
+ hashFile h tmp
{- Injects some content into git, returning its Sha.
-
import System.PosixCompat.Files (fileMode)
#endif
-import qualified System.FilePath.ByteString as P
-
data Hook = Hook
- { hookName :: RawFilePath
+ { hookName :: OsPath
, hookScript :: String
, hookOldScripts :: [String]
}
instance Eq Hook where
a == b = hookName a == hookName b
-hookFile :: Hook -> Repo -> RawFilePath
-hookFile h r = localGitDir r P.</> "hooks" P.</> hookName h
+hookFile :: Hook -> Repo -> OsPath
+hookFile h r = localGitDir r </> literalOsPath "hooks" </> hookName h
{- Writes a hook. Returns False if the hook already exists with a different
- content. Upgrades old scripts.
- is run with a bundled bash, so should start with #!/bin/sh
-}
hookWrite :: Hook -> Repo -> IO Bool
-hookWrite h r = ifM (doesFileExist (fromRawFilePath f))
+hookWrite h r = ifM (doesFileExist f)
( expectedContent h r >>= \case
UnexpectedContent -> return False
ExpectedContent -> return True
-- Hook scripts on Windows could use CRLF endings, but
-- they typically use unix newlines, which does work there
-- and makes the repository more portable.
- viaTmp F.writeFile' (toOsPath f) (encodeBS (hookScript h))
+ viaTmp F.writeFile' f (encodeBS (hookScript h))
void $ tryIO $ modifyFileMode f (addModes executeModes)
return True
, return True
)
where
- f = fromRawFilePath $ hookFile h r
+ f = hookFile h r
data ExpectedContent = UnexpectedContent | ExpectedContent | OldExpectedContent
-- and so a hook file that has CRLF will be treated the same as one
-- that has LF. That is intentional, since users may have a reason
-- to prefer one or the other.
- content <- readFile $ fromRawFilePath $ hookFile h r
+ content <- readFile $ fromOsPath $ hookFile h r
return $ if content == hookScript h
then ExpectedContent
else if any (content ==) (hookOldScripts h)
let f = hookFile h r
catchBoolIO $
#ifndef mingw32_HOST_OS
- isExecutable . fileMode <$> R.getFileStatus f
+ isExecutable . fileMode <$> R.getFileStatus (fromOsPath f)
#else
- doesFileExist (fromRawFilePath f)
+ doesFileExist f
#endif
runHook :: (FilePath -> [CommandParam] -> IO a) -> Hook -> [CommandParam] -> Repo -> IO a
runHook runner h ps r = do
- let f = fromRawFilePath $ hookFile h r
+ let f = hookFile h r
(c, cps) <- findShellCommand f
runner c (cps ++ ps)
import Utility.Env
import Utility.Env.Set
-import qualified System.FilePath.ByteString as P
-
indexEnv :: String
indexEnv = "GIT_INDEX_FILE"
-
- So, an absolute path is the only safe option for this to return.
-}
-indexEnvVal :: RawFilePath -> IO String
-indexEnvVal p = fromRawFilePath <$> absPath p
+indexEnvVal :: OsPath -> IO OsPath
+indexEnvVal p = absPath p
{- Forces git to use the specified index file.
-
-
- Warning: Not thread safe.
-}
-override :: RawFilePath -> Repo -> IO (IO ())
+override :: OsPath -> Repo -> IO (IO ())
override index _r = do
res <- getEnv var
val <- indexEnvVal index
- setEnv var val True
+ setEnv var (fromOsPath val) True
return $ reset res
where
var = "GIT_INDEX_FILE"
reset _ = unsetEnv var
{- The normal index file. Does not check GIT_INDEX_FILE. -}
-indexFile :: Repo -> RawFilePath
-indexFile r = localGitDir r P.</> "index"
+indexFile :: Repo -> OsPath
+indexFile r = localGitDir r </> literalOsPath "index"
{- The index file git will currently use, checking GIT_INDEX_FILE. -}
-currentIndexFile :: Repo -> IO RawFilePath
-currentIndexFile r = maybe (indexFile r) toRawFilePath <$> getEnv indexEnv
+currentIndexFile :: Repo -> IO OsPath
+currentIndexFile r = maybe (indexFile r) toOsPath <$> getEnv indexEnv
{- Git locks the index by creating this file. -}
-indexFileLock :: RawFilePath -> RawFilePath
-indexFileLock f = f <> ".lock"
+indexFileLock :: OsPath -> OsPath
+indexFileLock f = f <> literalOsPath ".lock"
#endif
#ifndef mingw32_HOST_OS
-data LockHandle = LockHandle FilePath Fd
+data LockHandle = LockHandle OsPath Fd
#else
-data LockHandle = LockHandle FilePath HANDLE
+data LockHandle = LockHandle OsPath HANDLE
#endif
{- Uses the same exclusive locking that git does.
- a dangling lock can be left if a process is terminated at the wrong
- time.
-}
-openLock :: FilePath -> IO LockHandle
+openLock :: OsPath -> IO LockHandle
openLock lck = openLock' lck `catchNonAsync` lckerr
where
lckerr e = do
-- Same error message displayed by git.
whenM (doesFileExist lck) $
hPutStrLn stderr $ unlines
- [ "fatal: Unable to create '" ++ lck ++ "': " ++ show e
+ [ "fatal: Unable to create '" ++ fromOsPath lck ++ "': " ++ show e
, ""
, "If no other git process is currently running, this probably means a"
, "git process crashed in this repository earlier. Make sure no other git"
]
throwM e
-openLock' :: FilePath -> IO LockHandle
+openLock' :: OsPath -> IO LockHandle
openLock' lck = do
#ifndef mingw32_HOST_OS
-- On unix, git simply uses O_EXCL
- h <- openFdWithMode (toRawFilePath lck) ReadWrite (Just 0O666)
+ h <- openFdWithMode (fromOsPath lck) ReadWrite (Just 0O666)
(defaultFileFlags { exclusive = True })
setFdOption h CloseOnExec True
#else
-- So, all that's needed is a way to open the file, that fails
-- if the file already exists. Using CreateFile with CREATE_NEW
-- accomplishes that.
- h <- createFile lck gENERIC_WRITE fILE_SHARE_NONE Nothing
+ h <- createFile (fromOsPath lck) gENERIC_WRITE fILE_SHARE_NONE Nothing
cREATE_NEW fILE_ATTRIBUTE_NORMAL Nothing
#endif
return (LockHandle lck h)
data LoggedFileChange t = LoggedFileChange
{ changetime :: POSIXTime
, changed :: t
- , changedfile :: FilePath
+ , changedfile :: OsPath
, oldref :: Ref
, newref :: Ref
}
-> Maybe Ref
-> [FilePath]
-> [CommandParam]
- -> (Sha -> FilePath -> Maybe t)
+ -> (Sha -> OsPath -> Maybe t)
-> Repo
-> IO ([LoggedFileChange t], IO Bool)
getGitLog ref stopref fs os selector repo = do
--
-- The commitinfo is not included before all changelines, so
-- keep track of the most recently seen commitinfo.
-parseGitRawLog :: (Ref -> FilePath -> Maybe t) -> [String] -> [LoggedFileChange t]
+parseGitRawLog :: (Ref -> OsPath -> Maybe t) -> [String] -> [LoggedFileChange t]
parseGitRawLog selector = parse (deleteSha, epoch)
where
epoch = toEnum 0 :: POSIXTime
_ -> (oldcommitsha, oldts, cl')
mrc = do
(old, new) <- parseRawChangeLine cl
- v <- selector commitsha c2
+ let c2' = toOsPath c2
+ v <- selector commitsha c2'
return $ LoggedFileChange
{ changetime = ts
, changed = v
- , changedfile = c2
+ , changedfile = c2'
, oldref = old
, newref = new
}
import Utility.InodeCache
import Utility.TimeStamp
import Utility.Attoparsec
-import qualified Utility.RawFilePath as R
+import qualified Utility.OsString as OS
import System.Posix.Types
import qualified Data.Map as M
import qualified Data.ByteString as S
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.ByteString.Char8 as A8
-import qualified System.FilePath.ByteString as P
{- It's only safe to use git ls-files on the current repo, not on a remote.
-
{- Lists files that are checked into git's index at the specified paths.
- With no paths, all files are listed.
-}
-inRepo :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+inRepo :: [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
inRepo = inRepo' [Param "--cached"]
-inRepo' :: [CommandParam] -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-inRepo' ps os l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo
+inRepo' :: [CommandParam] -> [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
+inRepo' ps os l repo = guardSafeForLsFiles repo $ do
+ (fs, cleanup) <- pipeNullSplit' params repo
+ return (map toOsPath fs, cleanup)
where
params =
Param "ls-files" :
Param "-z" :
map opParam os ++ ps ++
- (Param "--" : map (File . fromRawFilePath) l)
+ (Param "--" : map (File . fromOsPath) l)
{- Lists the same files inRepo does, but with sha and mode. -}
-inRepoDetails :: [Options] -> [RawFilePath] -> Repo -> IO ([(RawFilePath, Sha, FileMode)], IO Bool)
+inRepoDetails :: [Options] -> [OsPath] -> Repo -> IO ([(OsPath, Sha, FileMode)], IO Bool)
inRepoDetails = stagedDetails' parser . map opParam
where
parser s = case parseStagedDetails s of
{- Files that are checked into the index or have been committed to a
- branch. -}
-inRepoOrBranch :: Branch -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+inRepoOrBranch :: Branch -> [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
inRepoOrBranch b = inRepo'
[ Param "--cached"
, Param ("--with-tree=" ++ fromRef b)
]
{- Scans for files at the specified locations that are not checked into git. -}
-notInRepo :: [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+notInRepo :: [Options] -> Bool -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
notInRepo = notInRepo' []
-notInRepo' :: [CommandParam] -> [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+notInRepo' :: [CommandParam] -> [Options] -> Bool -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
notInRepo' ps os include_ignored =
inRepo' (Param "--others" : ps ++ exclude) os
where
{- Scans for files at the specified locations that are not checked into
- git. Empty directories are included in the result. -}
-notInRepoIncludingEmptyDirectories :: [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+notInRepoIncludingEmptyDirectories :: [Options] -> Bool -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"]
{- Finds all files in the specified locations, whether checked into git or
- not. -}
-allFiles :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+allFiles :: [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
allFiles = inRepo' [Param "--cached", Param "--others"]
{- Returns a list of files in the specified locations that have been
- deleted. -}
-deleted :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+deleted :: [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
deleted = inRepo' [Param "--deleted"]
{- Returns a list of files in the specified locations that have been
- modified. -}
-modified :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+modified :: [Options] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
modified = inRepo' [Param "--modified"]
{- Returns a list of all files that are staged for commit. -}
-staged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+staged :: [OsPath] -> Repo -> IO ([OsPath], IO Bool)
staged = staged' []
{- Returns a list of the files, staged for commit, that are being added,
- moved, or changed (but not deleted), from the specified locations. -}
-stagedNotDeleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+stagedNotDeleted :: [OsPath] -> Repo -> IO ([OsPath], IO Bool)
stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"]
-staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
-staged' ps l repo = guardSafeForLsFiles repo $
- pipeNullSplit' (prefix ++ ps ++ suffix) repo
+staged' :: [CommandParam] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
+staged' ps l repo = guardSafeForLsFiles repo $ do
+ (fs, cleanup) <- pipeNullSplit' (prefix ++ ps ++ suffix) repo
+ return (map toOsPath fs, cleanup)
where
prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"]
- suffix = Param "--" : map (File . fromRawFilePath) l
+ suffix = Param "--" : map (File . fromOsPath) l
-type StagedDetails = (RawFilePath, Sha, FileMode, StageNum)
+type StagedDetails = (OsPath, Sha, FileMode, StageNum)
type StageNum = Int
- Note that, during a conflict, a file will appear in the list
- more than once with different stage numbers.
-}
-stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
+stagedDetails :: [OsPath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedDetails = stagedDetails' parseStagedDetails []
-stagedDetails' :: (S.ByteString -> Maybe t) -> [CommandParam] -> [RawFilePath] -> Repo -> IO ([t], IO Bool)
+stagedDetails' :: (S.ByteString -> Maybe t) -> [CommandParam] -> [OsPath] -> Repo -> IO ([t], IO Bool)
stagedDetails' parser ps l repo = guardSafeForLsFiles repo $ do
(ls, cleanup) <- pipeNullSplit' params repo
return (mapMaybe parser ls, cleanup)
where
params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++
- Param "--" : map (File . fromRawFilePath) l
+ Param "--" : map (File . fromOsPath) l
parseStagedDetails :: S.ByteString -> Maybe StagedDetails
parseStagedDetails = eitherToMaybe . A.parseOnly parser
stagenum <- A8.decimal
void $ A8.char '\t'
file <- A.takeByteString
- return (file, sha, mode, stagenum)
+ return (toOsPath file, sha, mode, stagenum)
nextword = A8.takeTill (== ' ')
{- Returns a list of the files in the specified locations that are staged
- for commit, and whose type has changed. -}
-typeChangedStaged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+typeChangedStaged :: [OsPath] -> Repo -> IO ([OsPath], IO Bool)
typeChangedStaged = typeChanged' [Param "--cached"]
{- Returns a list of the files in the specified locations whose type has
- changed. Files only staged for commit will not be included. -}
-typeChanged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+typeChanged :: [OsPath] -> Repo -> IO ([OsPath], IO Bool)
typeChanged = typeChanged' []
-typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
+typeChanged' :: [CommandParam] -> [OsPath] -> Repo -> IO ([OsPath], IO Bool)
typeChanged' ps l repo = guardSafeForLsFiles repo $ do
(fs, cleanup) <- pipeNullSplit' (prefix ++ ps ++ suffix) repo
-- git diff returns filenames relative to the top of the git repo;
-- convert to filenames relative to the cwd, like git ls-files.
top <- absPath (repoPath repo)
- currdir <- R.getCurrentDirectory
- return (map (\f -> relPathDirToFileAbs currdir $ top P.</> f) fs, cleanup)
+ currdir <- getCurrentDirectory
+ return (map (\f -> relPathDirToFileAbs currdir $ top </> toOsPath f) fs, cleanup)
where
prefix =
[ Param "diff"
, Param "--diff-filter=T"
, Param "-z"
]
- suffix = Param "--" : (if null l then [File "."] else map (File . fromRawFilePath) l)
+ suffix = Param "--" : (if null l then [File "."] else map (File . fromOsPath) l)
{- A item in conflict has two possible values.
- Either can be Nothing, when that side deleted the file. -}
} deriving (Show)
data Unmerged = Unmerged
- { unmergedFile :: RawFilePath
+ { unmergedFile :: OsPath
, unmergedTreeItemType :: Conflicting TreeItemType
, unmergedSha :: Conflicting Sha
- , unmergedSiblingFile :: Maybe RawFilePath
+ , unmergedSiblingFile :: Maybe OsPath
-- ^ Normally this is Nothing, because a
-- merge conflict is represented as a single file with two
-- stages. However, git resolvers sometimes choose to stage
- 3 = them
- If line 2 or 3 is omitted, that side removed the file.
-}
-unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool)
+unmerged :: [OsPath] -> Repo -> IO ([Unmerged], IO Bool)
unmerged l repo = guardSafeForLsFiles repo $ do
(fs, cleanup) <- pipeNullSplit params repo
return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL) fs, cleanup)
Param "--unmerged" :
Param "-z" :
Param "--" :
- map (File . fromRawFilePath) l
+ map (File . fromOsPath) l
data InternalUnmerged = InternalUnmerged
{ isus :: Bool
- , ifile :: RawFilePath
+ , ifile :: OsPath
, itreeitemtype :: Maybe TreeItemType
, isha :: Maybe Sha
} deriving (Show)
else do
treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype)
sha <- extractSha (encodeBS rawsha)
- return $ InternalUnmerged (stage == 2) (toRawFilePath file)
+ return $ InternalUnmerged (stage == 2) (toOsPath file)
(Just treeitemtype) (Just sha)
_ -> Nothing
where
-- foo~<ref> are unmerged sibling files of foo
-- Some versions or resolvers of git stage the sibling files,
-- other versions or resolvers do not.
- issibfile x y = (ifile x <> "~") `S.isPrefixOf` ifile y
+ issibfile x y = (ifile x <> literalOsPath "~") `OS.isPrefixOf` ifile y
&& isus x || isus y
&& not (isus x && isus y)
- Note that this uses a --debug option whose output could change at some
- point in the future. If the output is not as expected, will use Nothing.
-}
-inodeCaches :: [RawFilePath] -> Repo -> IO ([(FilePath, Maybe InodeCache)], IO Bool)
+inodeCaches :: [OsPath] -> Repo -> IO ([(OsPath, Maybe InodeCache)], IO Bool)
inodeCaches locs repo = guardSafeForLsFiles repo $ do
(ls, cleanup) <- pipeNullSplit params repo
return (parse Nothing (map decodeBL ls), cleanup)
Param "-z" :
Param "--debug" :
Param "--" :
- map (File . fromRawFilePath) locs
+ map (File . fromOsPath) locs
parse Nothing (f:ls) = parse (Just f) ls
parse (Just f) (s:[]) =
let i = parsedebug s
- in (f, i) : []
+ in (toOsPath f, i) : []
parse (Just f) (s:ls) =
let (d, f') = splitdebug s
i = parsedebug d
- in (f, i) : parse (Just f') ls
+ in (toOsPath f, i) : parse (Just f') ls
parse _ _ = []
-- First 5 lines are --debug output, remainder is the next filename.
-- sha
<*> (Ref <$> A8.takeTill A8.isSpace)
- fileparser = asTopFilePath . Git.Quote.unquote <$> A.takeByteString
+ fileparser = asTopFilePath . toOsPath . Git.Quote.unquote
+ <$> A.takeByteString
sizeparser = fmap Just A8.decimal
[ encodeBS (showOct (mode ti) "")
, typeobj ti
, fromRef' (sha ti)
- ] <> (S.cons (fromIntegral (ord '\t')) (getTopFilePath (file ti)))
+ ]
+ <> (S.cons (fromIntegral (ord '\t'))
+ (fromOsPath (getTopFilePath (file ti))))
import Common
import Git
import Git.Sha
+import qualified Utility.OsString as OS
import qualified Data.ByteString as B
-import qualified System.FilePath.ByteString as P
+objectsDir :: Repo -> OsPath
+objectsDir r = localGitDir r </> literalOsPath "objects"
-objectsDir :: Repo -> RawFilePath
-objectsDir r = localGitDir r P.</> "objects"
+packDir :: Repo -> OsPath
+packDir r = objectsDir r </> literalOsPath "pack"
-packDir :: Repo -> RawFilePath
-packDir r = objectsDir r P.</> "pack"
+packIdxFile :: OsPath -> OsPath
+packIdxFile = flip replaceExtension (literalOsPath "idx")
-packIdxFile :: RawFilePath -> RawFilePath
-packIdxFile = flip P.replaceExtension "idx"
-
-listPackFiles :: Repo -> IO [RawFilePath]
-listPackFiles r = filter (".pack" `B.isSuffixOf`)
+listPackFiles :: Repo -> IO [OsPath]
+listPackFiles r = filter (literalOsPath ".pack" `OS.isSuffixOf`)
<$> catchDefaultIO [] (dirContents $ packDir r)
listLooseObjectShas :: Repo -> IO [Sha]
listLooseObjectShas r = catchDefaultIO [] $
- mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories . decodeBS)
- <$> emptyWhenDoesNotExist (dirContentsRecursiveSkipping (== "pack") True (objectsDir r))
+ mapMaybe conv <$> emptyWhenDoesNotExist
+ (dirContentsRecursiveSkipping ispackdir True (objectsDir r))
+ where
+ conv :: OsPath -> Maybe Sha
+ conv = extractSha
+ . fromOsPath
+ . OS.concat
+ . reverse
+ . take 2
+ . reverse
+ . splitDirectories
+ ispackdir f = f == literalOsPath "pack"
-looseObjectFile :: Repo -> Sha -> RawFilePath
-looseObjectFile r sha = objectsDir r P.</> prefix P.</> rest
+looseObjectFile :: Repo -> Sha -> OsPath
+looseObjectFile r sha = objectsDir r </> toOsPath prefix </> toOsPath rest
where
(prefix, rest) = B.splitAt 2 (fromRef' sha)
listAlternates :: Repo -> IO [FilePath]
listAlternates r = catchDefaultIO [] $
- lines <$> readFile (fromRawFilePath alternatesfile)
+ lines <$> readFile (fromOsPath alternatesfile)
where
- alternatesfile = objectsDir r P.</> "info" P.</> "alternates"
+ alternatesfile = objectsDir r </> literalOsPath "info" </> literalOsPath "alternates"
{- A repository recently cloned with --shared will have one or more
- alternates listed, and contain no loose objects or packs. -}
- those will be run before the FlushAction is. -}
| FlushAction
{ getFlushActionRunner :: FlushActionRunner m
- , getFlushActionFiles :: [RawFilePath]
+ , getFlushActionFiles :: [OsPath]
}
{- The String must be unique for each flush action. -}
-data FlushActionRunner m = FlushActionRunner String (Repo -> [RawFilePath] -> m ())
+data FlushActionRunner m = FlushActionRunner String (Repo -> [OsPath] -> m ())
instance Eq (FlushActionRunner m) where
FlushActionRunner s1 _ == FlushActionRunner s2 _ = s1 == s2
{- Adds an flush action to the queue. This can co-exist with anything else
- that gets added to the queue, and when the queue is eventually flushed,
- it will be run after the other things in the queue. -}
-addFlushAction :: MonadIO m => FlushActionRunner m -> [RawFilePath] -> Queue m -> Repo -> m (Queue m)
+addFlushAction :: MonadIO m => FlushActionRunner m -> [OsPath] -> Queue m -> Repo -> m (Queue m)
addFlushAction runner files q repo =
updateQueue action (const False) (length files) q repo
where
-}
{-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
module Git.Quote (
unquote,
noquote = id
+#ifdef WITH_OSPATH
+instance Quoteable OsPath where
+ quote qp f = quote qp (fromOsPath f :: RawFilePath)
+ noquote = fromOsPath
+#endif
+
-- Allows building up a string that contains paths, which will get quoted.
-- With OverloadedStrings, strings are passed through without quoting.
-- Eg: QuotedPath f <> ": not found"
data StringContainingQuotedPath
= UnquotedString String
| UnquotedByteString S.ByteString
- | QuotedPath RawFilePath
+ | QuotedPath OsPath
| StringContainingQuotedPath :+: StringContainingQuotedPath
deriving (Show, Eq)
-quotedPaths :: [RawFilePath] -> StringContainingQuotedPath
+quotedPaths :: [OsPath] -> StringContainingQuotedPath
quotedPaths [] = mempty
quotedPaths (p:ps) = QuotedPath p <> if null ps
then mempty
instance Quoteable StringContainingQuotedPath where
quote _ (UnquotedString s) = safeOutput (encodeBS s)
quote _ (UnquotedByteString s) = safeOutput s
- quote qp (QuotedPath p) = quote qp p
+ quote qp (QuotedPath p) = quote qp (fromOsPath p :: RawFilePath)
quote qp (a :+: b) = quote qp a <> quote qp b
noquote (UnquotedString s) = encodeBS s
noquote (UnquotedByteString s) = s
- noquote (QuotedPath p) = p
+ noquote (QuotedPath p) = fromOsPath p
noquote (a :+: b) = noquote a <> noquote b
instance IsString StringContainingQuotedPath where
import Data.Char (chr, ord)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
-import qualified System.FilePath.ByteString as P
headRef :: Ref
headRef = Ref "HEAD"
-headFile :: Repo -> RawFilePath
-headFile r = localGitDir r P.</> "HEAD"
+headFile :: Repo -> OsPath
+headFile r = localGitDir r </> literalOsPath "HEAD"
setHeadRef :: Ref -> Repo -> IO ()
setHeadRef ref r =
- F.writeFile' (toOsPath (headFile r)) ("ref: " <> fromRef' ref)
+ F.writeFile' (headFile r) ("ref: " <> fromRef' ref)
{- Converts a fully qualified git ref into a user-visible string. -}
describe :: Ref -> String
-
- If the input file is located outside the repository, returns Nothing.
-}
-fileRef :: RawFilePath -> Repo -> IO (Maybe Ref)
+fileRef :: OsPath -> Repo -> IO (Maybe Ref)
fileRef f repo = do
-- The filename could be absolute, or contain eg "../repo/file",
-- neither of which work in a ref, so convert it to a minimal
-- Prefixing the file with ./ makes this work even when in a
-- subdirectory of a repo. Eg, ./foo in directory bar refers
-- to bar/foo, not to foo in the top of the repository.
- then Just $ Ref $ ":./" <> toInternalGitPath f'
+ then Just $ Ref $ ":./" <> fromOsPath (toInternalGitPath f')
else Nothing
{- A Ref that can be used to refer to a file in a particular branch. -}
-branchFileRef :: Branch -> RawFilePath -> Ref
-branchFileRef branch f = Ref $ fromRef' branch <> ":" <> toInternalGitPath f
+branchFileRef :: Branch -> OsPath -> Ref
+branchFileRef branch f = Ref $ fromOsPath $
+ toOsPath (fromRef' branch) <> literalOsPath ":" <> toInternalGitPath f
{- Converts a Ref to refer to the content of the Ref on a given date. -}
dateRef :: Ref -> RefDate -> Ref
-
- If the file path is located outside the repository, returns Nothing.
-}
-fileFromRef :: Ref -> RawFilePath -> Repo -> IO (Maybe Ref)
+fileFromRef :: Ref -> OsPath -> Repo -> IO (Maybe Ref)
fileFromRef r f repo = fileRef f repo >>= return . \case
Just (Ref fr) -> Just (Ref (fromRef' r <> fr))
Nothing -> Nothing
{- The file used to record a ref. (Git also stores some refs in a
- packed-refs file.) -}
-file :: Ref -> Repo -> FilePath
-file ref repo = fromRawFilePath (localGitDir repo) </> fromRef ref
+file :: Ref -> Repo -> OsPath
+file ref repo = localGitDir repo </> toOsPath (fromRef' ref)
{- Checks if HEAD exists. It generally will, except for in a repository
- that was just created. -}
import Utility.Tmp.Dir
import Utility.Rsync
import Utility.FileMode
-import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import qualified Data.Set as S
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
-import qualified System.FilePath.ByteString as P
{- Given a set of bad objects found by git fsck, which may not
- be complete, finds and removes all corrupt objects. -}
mapM_ removeLoose (S.toList $ knownMissing fsckresults)
mapM_ removeBad =<< listLooseObjectShas r
where
- removeLoose s = removeWhenExistsWith R.removeLink (looseObjectFile r s)
+ removeLoose s = removeWhenExistsWith removeFile $ looseObjectFile r s
removeBad s = do
void $ tryIO $ allowRead $ looseObjectFile r s
whenM (isMissing s r) $
explodePacks r = go =<< listPackFiles r
where
go [] = return False
- go packs = withTmpDir (toOsPath "packs") $ \tmpdir -> do
- r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" tmpdir
+ go packs = withTmpDir (literalOsPath "packs") $ \tmpdir -> do
+ r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" (fromOsPath tmpdir)
putStrLn "Unpacking all pack files."
forM_ packs $ \packfile -> do
-- Just in case permissions are messed up.
-- May fail, if pack file is corrupt.
void $ tryIO $
pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h ->
- L.hPut h =<< F.readFile (toOsPath packfile)
- objs <- emptyWhenDoesNotExist (dirContentsRecursive (toRawFilePath tmpdir))
+ L.hPut h =<< F.readFile packfile
+ objs <- emptyWhenDoesNotExist (dirContentsRecursive tmpdir)
forM_ objs $ \objfile -> do
- f <- relPathDirToFile
- (toRawFilePath tmpdir)
- objfile
- let dest = objectsDir r P.</> f
- createDirectoryIfMissing True
- (fromRawFilePath (parentDir dest))
+ f <- relPathDirToFile tmpdir objfile
+ let dest = objectsDir r </> f
+ createDirectoryIfMissing True (parentDir dest)
moveFile objfile dest
forM_ packs $ \packfile -> do
- removeWhenExistsWith R.removeLink packfile
- removeWhenExistsWith R.removeLink (packIdxFile packfile)
+ removeWhenExistsWith removeFile packfile
+ removeWhenExistsWith removeFile (packIdxFile packfile)
return True
{- Try to retrieve a set of missing objects, from the remotes of a
retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults
retrieveMissingObjects missing referencerepo r
| not (foundBroken missing) = return missing
- | otherwise = withTmpDir (toOsPath "tmprepo") $ \tmpdir -> do
- unlessM (boolSystem "git" [Param "init", File tmpdir]) $
- giveup $ "failed to create temp repository in " ++ tmpdir
- tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir)
- let repoconfig r' = toOsPath (localGitDir r' P.</> "config")
- whenM (doesFileExist (fromRawFilePath (fromOsPath (repoconfig r)))) $
+ | otherwise = withTmpDir (literalOsPath "tmprepo") $ \tmpdir -> do
+ unlessM (boolSystem "git" [Param "init", File (fromOsPath tmpdir)]) $
+ giveup $ "failed to create temp repository in " ++ fromOsPath tmpdir
+ tmpr <- Config.read =<< Construct.fromPath tmpdir
+ let repoconfig r' = localGitDir r' </> literalOsPath "config"
+ whenM (doesFileExist (repoconfig r)) $
F.readFile (repoconfig r) >>= F.writeFile (repoconfig tmpr)
rs <- Construct.fromRemotes r
stillmissing <- pullremotes tmpr rs fetchrefstags missing
copyObjects :: Repo -> Repo -> IO Bool
copyObjects srcr destr = rsync
[ Param "-qr"
- , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir srcr
- , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir destr
+ , File $ fromOsPath $ addTrailingPathSeparator $ objectsDir srcr
+ , File $ fromOsPath $ addTrailingPathSeparator $ objectsDir destr
]
{- To deal with missing objects that cannot be recovered, resets any
- Relies on packed refs being exploded before it's called.
-}
getAllRefs :: Repo -> IO [Ref]
-getAllRefs r = getAllRefs' (localGitDir r P.</> "refs")
+getAllRefs r = getAllRefs' (localGitDir r </> literalOsPath "refs")
-getAllRefs' :: RawFilePath -> IO [Ref]
+getAllRefs' :: OsPath -> IO [Ref]
getAllRefs' refdir = do
- let topsegs = length (P.splitPath refdir) - 1
- let toref = Ref . toInternalGitPath . encodeBS
+ let topsegs = length (splitPath refdir) - 1
+ let toref = Ref . fromOsPath . toInternalGitPath
. joinPath . drop topsegs . splitPath
- . decodeBS
map toref <$> emptyWhenDoesNotExist (dirContentsRecursive refdir)
explodePackedRefsFile :: Repo -> IO ()
explodePackedRefsFile r = do
let f = packedRefsFile r
- let f' = toRawFilePath f
whenM (doesFileExist f) $ do
rs <- mapMaybe parsePacked
. map decodeBS
. fileLines'
- <$> catchDefaultIO "" (safeReadFile f')
+ <$> catchDefaultIO "" (safeReadFile f)
forM_ rs makeref
- removeWhenExistsWith R.removeLink f'
+ removeWhenExistsWith removeFile f
where
makeref (sha, ref) = do
let gitd = localGitDir r
- let dest = gitd P.</> fromRef' ref
- let dest' = fromRawFilePath dest
+ let dest = gitd </> toOsPath (fromRef' ref)
createDirectoryUnder [gitd] (parentDir dest)
- unlessM (doesFileExist dest') $
- writeFile dest' (fromRef sha)
+ unlessM (doesFileExist dest) $
+ writeFile (fromOsPath dest) (fromRef sha)
-packedRefsFile :: Repo -> FilePath
-packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs"
+packedRefsFile :: Repo -> OsPath
+packedRefsFile r = localGitDir r </> literalOsPath "packed-refs"
parsePacked :: String -> Maybe (Sha, Ref)
parsePacked l = case words l of
{- git-branch -d cannot be used to remove a branch that is directly
- pointing to a corrupt commit. -}
nukeBranchRef :: Branch -> Repo -> IO ()
-nukeBranchRef b r = removeWhenExistsWith R.removeLink $ localGitDir r P.</> fromRef' b
+nukeBranchRef b r = removeWhenExistsWith removeFile $
+ localGitDir r </> toOsPath (fromRef' b)
{- Finds the most recent commit to a branch that does not need any
- of the missing objects. If the input branch is good as-is, returns it.
length indexcontents `seq` cleanup
missingIndex :: Repo -> IO Bool
-missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) </> "index")
+missingIndex r = not <$> doesFileExist (localGitDir r </> literalOsPath "index")
{- Finds missing and ok files staged in the index. -}
partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)
| otherwise = do
(bad, good, cleanup) <- partitionIndex r
unless (null bad) $ do
- removeWhenExistsWith R.removeLink (indexFile r)
+ removeWhenExistsWith removeFile (indexFile r)
UpdateIndex.streamUpdateIndex r
=<< (catMaybes <$> mapM reinject good)
void cleanup
- return $ map (\(file,_, _, _) -> fromRawFilePath file) bad
+ return $ map (\(file,_, _, _) -> fromOsPath file) bad
where
reinject (file, sha, mode, _) = case toTreeItemType mode of
Nothing -> return Nothing
preRepair :: Repo -> IO ()
preRepair g = do
unlessM (validhead <$> catchDefaultIO "" (decodeBS <$> safeReadFile headfile)) $ do
- removeWhenExistsWith R.removeLink headfile
- writeFile (fromRawFilePath headfile) "ref: refs/heads/master"
+ removeWhenExistsWith removeFile headfile
+ writeFile (fromOsPath headfile) "ref: refs/heads/master"
explodePackedRefsFile g
unless (repoIsLocalBare g) $
void $ tryIO $ allowWrite $ indexFile g
where
- headfile = localGitDir g P.</> "HEAD"
+ headfile = localGitDir g </> literalOsPath "HEAD"
validhead s = "ref: refs/" `isPrefixOf` s
|| isJust (extractSha (encodeBS s))
else successfulfinish modifiedbranches
corruptedindex = do
- removeWhenExistsWith R.removeLink (indexFile g)
+ removeWhenExistsWith removeFile (indexFile g)
-- The corrupted index can prevent fsck from finding other
-- problems, so re-run repair.
fsckresult' <- findBroken False False g
successfulRepair :: (Bool, [Branch]) -> Bool
successfulRepair = fst
-safeReadFile :: RawFilePath -> IO B.ByteString
+safeReadFile :: OsPath -> IO B.ByteString
safeReadFile f = do
allowRead f
- F.readFile' (toOsPath f)
+ F.readFile' f
in go (v : c) xs'
_ -> go c xs
- cparse 'M' f _ = (Just (Modified (asTopFilePath (toRawFilePath f))), Nothing)
- cparse 'A' f _ = (Just (Added (asTopFilePath (toRawFilePath f))), Nothing)
- cparse 'D' f _ = (Just (Deleted (asTopFilePath (toRawFilePath f))), Nothing)
- cparse 'T' f _ = (Just (TypeChanged (asTopFilePath (toRawFilePath f))), Nothing)
- cparse '?' f _ = (Just (Untracked (asTopFilePath (toRawFilePath f))), Nothing)
+ cparse 'M' f _ = (Just (Modified (asTopFilePath (toOsPath f))), Nothing)
+ cparse 'A' f _ = (Just (Added (asTopFilePath (toOsPath f))), Nothing)
+ cparse 'D' f _ = (Just (Deleted (asTopFilePath (toOsPath f))), Nothing)
+ cparse 'T' f _ = (Just (TypeChanged (asTopFilePath (toOsPath f))), Nothing)
+ cparse '?' f _ = (Just (Untracked (asTopFilePath (toOsPath f))), Nothing)
cparse 'R' f (oldf:xs) =
- (Just (Renamed (asTopFilePath (toRawFilePath oldf)) (asTopFilePath (toRawFilePath f))), Just xs)
+ (Just (Renamed (asTopFilePath (toOsPath oldf)) (asTopFilePath (toOsPath f))), Just xs)
cparse _ _ _ = (Nothing, Nothing)
getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedUnstaged Status], IO Bool)
, " "
, fromRef s
, "\t"
- , takeFileName (fromRawFilePath (getTopFilePath f))
+ , fromOsPath (takeFileName (getTopFilePath f))
, "\NUL"
]
Just (NewSubTree d l) ->
go (addsubtree idir m (NewSubTree d (c:l))) is
_ ->
- go (addsubtree idir m (NewSubTree (asTopFilePath idir) [c])) is
+ go (addsubtree idir m (NewSubTree (asTopFilePath (toOsPath idir)) [c])) is
where
p = gitPath i
idir = P.takeDirectory p
Just (NewSubTree d' l) ->
let l' = filter (\ti -> gitPath ti /= d) l
in addsubtree parent m' (NewSubTree d' (t:l'))
- _ -> addsubtree parent m' (NewSubTree (asTopFilePath parent) [t])
+ _ -> addsubtree parent m' (NewSubTree (asTopFilePath (toOsPath parent)) [t])
| otherwise = M.insert d t m
where
parent = P.takeDirectory d
subdirs = P.splitDirectories $ gitPath graftloc
- graftdirs = map (asTopFilePath . toInternalGitPath) $
+ graftdirs = map (asTopFilePath . toInternalGitPath . toOsPath) $
pathPrefixes subdirs
{- Assumes the list is ordered, with tree objects coming right before their
gitPath = toRawFilePath
instance GitPath TopFilePath where
- gitPath = getTopFilePath
+ gitPath = fromOsPath . getTopFilePath
instance GitPath TreeItem where
gitPath (TreeItem f _ _) = gitPath f
-}
{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
module Git.Types where
+import Utility.SafeCommand
+import Utility.FileSystemEncoding
+import Utility.OsPath
+
import Network.URI
import Data.String
import Data.Default
import qualified Data.ByteString as S
import qualified Data.List.NonEmpty as NE
import System.Posix.Types
-import Utility.SafeCommand
-import Utility.FileSystemEncoding
import qualified Data.Semigroup as Sem
import Prelude
- else known about it.
-}
data RepoLocation
- = Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath }
- | LocalUnknown RawFilePath
+ = Local { gitdir :: OsPath, worktree :: Maybe OsPath }
+ | LocalUnknown OsPath
| Url URI
| UnparseableUrl String
| Unknown
instance FromConfigValue String where
fromConfigValue = decodeBS . fromConfigValue
+#ifdef WITH_OSPATH
+instance FromConfigValue OsPath where
+ fromConfigValue v = toOsPath (fromConfigValue v :: S.ByteString)
+#endif
+
instance Show ConfigValue where
show = fromConfigValue
void $ cleanup
where
go [] = noop
- go (info:file:rest) = mergeFile info file hashhandle ch >>=
+ go (info:file:rest) = mergeFile info (toOsPath file) hashhandle ch >>=
maybe (go rest) (\l -> streamer l >> go rest)
go (_:[]) = giveup $ "parse error " ++ show differ
{- Given an info line from a git raw diff, and the filename, generates
- a line suitable for update-index that union merges the two sides of the
- diff. -}
-mergeFile :: S.ByteString -> RawFilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString)
+mergeFile :: S.ByteString -> OsPath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString)
mergeFile info file hashhandle h = case S8.words info of
[_colonmode, _bmode, asha, bsha, _status] ->
case filter (`notElem` nullShas) [Ref asha, Ref bsha] of
void $ cleanup
where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x]
+
lsSubTree :: Ref -> FilePath -> Repo -> Streamer
lsSubTree (Ref x) p repo streamer = do
(s, cleanup) <- pipeNullSplit params repo
<> " blob "
<> fromRef' sha
<> "\t"
- <> indexPath file
+ <> fromOsPath (indexPath file)
-stageFile :: Sha -> TreeItemType -> RawFilePath -> Repo -> IO Streamer
+stageFile :: Sha -> TreeItemType -> OsPath -> Repo -> IO Streamer
stageFile sha treeitemtype file repo = do
p <- toTopFilePath file repo
return $ pureStreamer $ updateIndexLine sha treeitemtype p
{- A streamer that removes a file from the index. -}
-unstageFile :: RawFilePath -> Repo -> IO Streamer
+unstageFile :: OsPath -> Repo -> IO Streamer
unstageFile file repo = do
p <- toTopFilePath file repo
return $ unstageFile' p
"0 "
<> fromRef' deleteSha
<> "\t"
- <> indexPath p
+ <> fromOsPath (indexPath p)
{- A streamer that adds a symlink to the index. -}
-stageSymlink :: RawFilePath -> Sha -> Repo -> IO Streamer
+stageSymlink :: OsPath -> Sha -> Repo -> IO Streamer
stageSymlink file sha repo = do
!line <- updateIndexLine
<$> pure sha
- update-index. Sending Nothing will wait for update-index to finish
- updating the index.
-}
-refreshIndex :: (MonadIO m, MonadMask m) => Repo -> ((Maybe RawFilePath -> IO ()) -> m ()) -> m ()
+refreshIndex :: (MonadIO m, MonadMask m) => Repo -> ((Maybe OsPath -> IO ()) -> m ()) -> m ()
refreshIndex repo feeder = bracket
(liftIO $ createProcess p)
(liftIO . cleanupProcess)
hClose h
forceSuccessProcess p pid
feeder $ \case
- Just f -> S.hPut h (S.snoc f 0)
+ Just f -> S.hPut h (S.snoc (fromOsPath f) 0)
Nothing -> closer
liftIO $ closer
go _ = error "internal"
keyParser,
serializeKey,
serializeKey',
+ serializeKey'',
deserializeKey,
deserializeKey',
nonChunkKey,
import qualified Data.Text as T
import qualified Data.ByteString as S
-import qualified Data.ByteString.Short as S (toShort, fromShort)
+import Data.ByteString.Short (ShortByteString, toShort, fromShort)
import qualified Data.Attoparsec.ByteString as A
import Common
serializeKey = decodeBS . serializeKey'
serializeKey' :: Key -> S.ByteString
-serializeKey' = S.fromShort . keySerialization
+serializeKey' = fromShort . keySerialization
+
+serializeKey'' :: Key -> ShortByteString
+serializeKey'' = keySerialization
deserializeKey :: String -> Maybe Key
deserializeKey = deserializeKey' . encodeBS
instance Arbitrary KeyData where
arbitrary = Key
- <$> (S.toShort . encodeBS <$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t"))
+ <$> (toShort . encodeBS <$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t"))
<*> (parseKeyVariety . encodeBS <$> (listOf1 $ elements ['A'..'Z'])) -- BACKEND
<*> ((abs <$>) <$> arbitrary) -- size cannot be negative
<*> ((abs . fromInteger <$>) <$> arbitrary) -- mtime cannot be negative
instance Arbitrary AssociatedFile where
arbitrary = AssociatedFile
- . fmap (toRawFilePath . fromTestableFilePath)
+ . fmap (toOsPath . fromTestableFilePath)
<$> arbitrary
instance Arbitrary Key where
import Data.Time.Clock.POSIX
import qualified Data.Set as S
import qualified Data.Map as M
-import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (accessTime, isSymbolicLink)
{- Some limits can look at the current status of files on
matchGlobFile glob = go
where
cglob = compileGlob glob CaseSensitive (GlobFilePath True) -- memoized
- go (MatchingFile fi) = pure $ matchGlob cglob (fromRawFilePath (matchFile fi))
+ go (MatchingFile fi) = pure $ matchGlob cglob (fromOsPath (matchFile fi))
go (MatchingInfo p) = pure $ case providedFilePath p of
- Just f -> matchGlob cglob (fromRawFilePath f)
+ Just f -> matchGlob cglob (fromOsPath f)
Nothing -> False
- go (MatchingUserInfo p) = matchGlob cglob <$> getUserInfo (userProvidedFilePath p)
+ go (MatchingUserInfo p) = matchGlob cglob . fromOsPath
+ <$> getUserInfo (userProvidedFilePath p)
{- Add a limit to skip files when there is no other file using the same
- content, with a name matching the glob. -}
Just f -> check k f
Nothing -> return False
go (MatchingUserInfo p) k =
- check k . toRawFilePath
- =<< getUserInfo (userProvidedFilePath p)
+ check k =<< getUserInfo (userProvidedFilePath p)
cglob = compileGlob glob CaseSensitive (GlobFilePath True) -- memoized
- matchesglob f = matchGlob cglob (fromRawFilePath f)
+ matchesglob f = matchGlob cglob (fromOsPath f)
#ifdef mingw32_HOST_OS
- || matchGlob cglob (fromRawFilePath (toInternalGitPath f))
+ || matchGlob cglob (fromOsPath (toInternalGitPath f))
#endif
check k skipf = do
-- Find other files with the same content, with filenames
-- matching the glob.
g <- Annex.gitRepo
- fs <- filter (/= P.normalise skipf)
+ fs <- filter (/= normalise skipf)
. filter matchesglob
- . map (\f -> P.normalise (fromTopFilePath f g))
+ . map (\f -> normalise (fromTopFilePath f g))
<$> Database.Keys.getAssociatedFiles k
-- Some associated files in the keys database may no longer
-- correspond to files in the repository. This is checked
addMagicLimit
:: String
- -> (Magic -> FilePath -> Annex (Maybe String))
+ -> (Magic -> OsPath -> Annex (Maybe String))
-> (ProvidedInfo -> Maybe String)
-> (UserProvidedInfo -> UserInfo String)
-> String
magic <- liftIO initMagicMime
addLimit $ matchMagic limitname querymagic' selectprovidedinfo selectuserprovidedinfo magic glob
where
- querymagic' magic f = liftIO (isPointerFile (toRawFilePath f)) >>= \case
+ querymagic' magic f = liftIO (isPointerFile f) >>= \case
-- Avoid getting magic of a pointer file, which would
-- wrongly be detected as text.
Just _ -> return Nothing
-- When the file is an annex symlink, get magic of the
-- object file.
- Nothing -> isAnnexLink (toRawFilePath f) >>= \case
- Just k -> withObjectLoc k $
- querymagic magic . fromRawFilePath
+ Nothing -> isAnnexLink f >>= \case
+ Just k -> withObjectLoc k (querymagic magic)
Nothing -> querymagic magic f
matchMagic
:: String
- -> (Magic -> FilePath -> Annex (Maybe String))
+ -> (Magic -> OsPath -> Annex (Maybe String))
-> (ProvidedInfo -> Maybe String)
-> (UserProvidedInfo -> UserInfo String)
-> Maybe Magic
cglob = compileGlob glob CaseSensitive (GlobFilePath False) -- memoized
go (MatchingFile fi) = catchBoolIO $
maybe False (matchGlob cglob)
- <$> querymagic magic (fromRawFilePath (contentFile fi))
+ <$> querymagic magic (contentFile fi)
go (MatchingInfo p) = maybe
(usecontent (providedKey p))
(pure . matchGlob cglob)
go (MatchingUserInfo p) =
matchGlob cglob <$> getUserInfo (selectuserprovidedinfo p)
usecontent (Just k) = withObjectLoc k $ \obj -> catchBoolIO $
- maybe False (matchGlob cglob)
- <$> querymagic magic (fromRawFilePath obj)
+ maybe False (matchGlob cglob) <$> querymagic magic obj
usecontent Nothing = pure False
matchMagic limitname _ _ _ Nothing _ =
Left $ "unable to load magic database; \""++limitname++"\" cannot be used"
islocked <- isPointerFile f >>= \case
Just _key -> return False
Nothing -> isSymbolicLink
- <$> R.getSymbolicLinkStatus f
+ <$> R.getSymbolicLinkStatus (fromOsPath f)
return (islocked == wantlocked)
matchLockStatus wantlocked (MatchingInfo p) =
pure $ case providedLinkType p of
}
{- Limit to content that is in a directory, anywhere in the repository tree -}
-limitInDir :: FilePath -> String -> MatchFiles Annex
+limitInDir :: OsPath -> String -> MatchFiles Annex
limitInDir dir desc = MatchFiles
{ matchAction = const $ const go
, matchNeedsFileName = True
, matchDesc = matchDescSimple desc
}
where
- go (MatchingFile fi) = checkf $ fromRawFilePath $ matchFile fi
- go (MatchingInfo p) = maybe (pure False) (checkf . fromRawFilePath) (providedFilePath p)
+ go (MatchingFile fi) = checkf $ matchFile fi
+ go (MatchingInfo p) = maybe (pure False) checkf (providedFilePath p)
go (MatchingUserInfo p) = checkf =<< getUserInfo (userProvidedFilePath p)
checkf = return . elem dir . splitPath . takeDirectory
where
check now k = inAnnexCheck k $ \f ->
liftIO $ catchDefaultIO False $ do
- s <- R.getSymbolicLinkStatus f
+ s <- R.getSymbolicLinkStatus (fromOsPath f)
let accessed = realToFrac (accessTime s)
let delta = now - accessed
return $ delta <= secs
import Annex.Common
import Annex.DirHashes
-
-import qualified Data.ByteString as S
-import qualified System.FilePath.ByteString as P
+import qualified Utility.OsString as OS
{- There are several varieties of log file formats. -}
data LogVariety
{- Converts a path from the git-annex branch into one of the varieties
- of logs used by git-annex, if it's a known path. -}
-getLogVariety :: GitConfig -> RawFilePath -> Maybe LogVariety
+getLogVariety :: GitConfig -> OsPath -> Maybe LogVariety
getLogVariety config f
| f `elem` topLevelOldUUIDBasedLogs = Just OldUUIDBasedLog
| f `elem` topLevelNewUUIDBasedLogs = Just NewUUIDBasedLog
logFilesToCache = 2
{- All the log files that might contain information about a key. -}
-keyLogFiles :: GitConfig -> Key -> [RawFilePath]
+keyLogFiles :: GitConfig -> Key -> [OsPath]
keyLogFiles config k =
[ locationLogFile config k
, urlLogFile config k
] ++ oldurlLogs config k
{- All uuid-based logs stored in the top of the git-annex branch. -}
-topLevelUUIDBasedLogs :: [RawFilePath]
+topLevelUUIDBasedLogs :: [OsPath]
topLevelUUIDBasedLogs = topLevelNewUUIDBasedLogs ++ topLevelOldUUIDBasedLogs
{- All the old-format uuid-based logs stored in the top of the git-annex branch. -}
-topLevelOldUUIDBasedLogs :: [RawFilePath]
+topLevelOldUUIDBasedLogs :: [OsPath]
topLevelOldUUIDBasedLogs =
[ uuidLog
, remoteLog
]
{- All the new-format uuid-based logs stored in the top of the git-annex branch. -}
-topLevelNewUUIDBasedLogs :: [RawFilePath]
+topLevelNewUUIDBasedLogs :: [OsPath]
topLevelNewUUIDBasedLogs =
[ exportLog
, proxyLog
]
{- Other top-level logs. -}
-otherTopLevelLogs :: [RawFilePath]
+otherTopLevelLogs :: [OsPath]
otherTopLevelLogs =
[ numcopiesLog
, mincopiesLog
, groupPreferredContentLog
]
-uuidLog :: RawFilePath
-uuidLog = "uuid.log"
+uuidLog :: OsPath
+uuidLog = literalOsPath "uuid.log"
-numcopiesLog :: RawFilePath
-numcopiesLog = "numcopies.log"
+numcopiesLog :: OsPath
+numcopiesLog = literalOsPath "numcopies.log"
-mincopiesLog :: RawFilePath
-mincopiesLog = "mincopies.log"
+mincopiesLog :: OsPath
+mincopiesLog = literalOsPath "mincopies.log"
-configLog :: RawFilePath
-configLog = "config.log"
+configLog :: OsPath
+configLog = literalOsPath "config.log"
-remoteLog :: RawFilePath
-remoteLog = "remote.log"
+remoteLog :: OsPath
+remoteLog = literalOsPath "remote.log"
-trustLog :: RawFilePath
-trustLog = "trust.log"
+trustLog :: OsPath
+trustLog = literalOsPath "trust.log"
-groupLog :: RawFilePath
-groupLog = "group.log"
+groupLog :: OsPath
+groupLog = literalOsPath "group.log"
-preferredContentLog :: RawFilePath
-preferredContentLog = "preferred-content.log"
+preferredContentLog :: OsPath
+preferredContentLog = literalOsPath "preferred-content.log"
-requiredContentLog :: RawFilePath
-requiredContentLog = "required-content.log"
+requiredContentLog :: OsPath
+requiredContentLog = literalOsPath "required-content.log"
-groupPreferredContentLog :: RawFilePath
-groupPreferredContentLog = "group-preferred-content.log"
+groupPreferredContentLog :: OsPath
+groupPreferredContentLog = literalOsPath "group-preferred-content.log"
-scheduleLog :: RawFilePath
-scheduleLog = "schedule.log"
+scheduleLog :: OsPath
+scheduleLog = literalOsPath "schedule.log"
-activityLog :: RawFilePath
-activityLog = "activity.log"
+activityLog :: OsPath
+activityLog = literalOsPath "activity.log"
-differenceLog :: RawFilePath
-differenceLog = "difference.log"
+differenceLog :: OsPath
+differenceLog = literalOsPath "difference.log"
-multicastLog :: RawFilePath
-multicastLog = "multicast.log"
+multicastLog :: OsPath
+multicastLog = literalOsPath "multicast.log"
-exportLog :: RawFilePath
-exportLog = "export.log"
+exportLog :: OsPath
+exportLog = literalOsPath "export.log"
-proxyLog :: RawFilePath
-proxyLog = "proxy.log"
+proxyLog :: OsPath
+proxyLog = literalOsPath "proxy.log"
-clusterLog :: RawFilePath
-clusterLog = "cluster.log"
+clusterLog :: OsPath
+clusterLog = literalOsPath "cluster.log"
-maxSizeLog :: RawFilePath
-maxSizeLog = "maxsize.log"
+maxSizeLog :: OsPath
+maxSizeLog = literalOsPath "maxsize.log"
{- This is not a log file, it's where exported treeishes get grafted into
- the git-annex branch. -}
-exportTreeGraftPoint :: RawFilePath
-exportTreeGraftPoint = "export.tree"
+exportTreeGraftPoint :: OsPath
+exportTreeGraftPoint = literalOsPath "export.tree"
{- This is not a log file, it's where migration treeishes get grafted into
- the git-annex branch. -}
-migrationTreeGraftPoint :: RawFilePath
-migrationTreeGraftPoint = "migrate.tree"
+migrationTreeGraftPoint :: OsPath
+migrationTreeGraftPoint = literalOsPath "migrate.tree"
{- The pathname of the location log file for a given key. -}
-locationLogFile :: GitConfig -> Key -> RawFilePath
+locationLogFile :: GitConfig -> Key -> OsPath
locationLogFile config key =
- branchHashDir config key P.</> keyFile key <> locationLogExt
+ branchHashDir config key </> keyFile key <> locationLogExt
-locationLogExt :: S.ByteString
-locationLogExt = ".log"
+locationLogExt :: OsPath
+locationLogExt = literalOsPath ".log"
{- The filename of the url log for a given key. -}
-urlLogFile :: GitConfig -> Key -> RawFilePath
+urlLogFile :: GitConfig -> Key -> OsPath
urlLogFile config key =
- branchHashDir config key P.</> keyFile key <> urlLogExt
+ branchHashDir config key </> keyFile key <> urlLogExt
{- Old versions stored the urls elsewhere. -}
-oldurlLogs :: GitConfig -> Key -> [RawFilePath]
+oldurlLogs :: GitConfig -> Key -> [OsPath]
oldurlLogs config key =
- [ "remote/web" P.</> hdir P.</> serializeKey' key <> ".log"
- , "remote/web" P.</> hdir P.</> keyFile key <> ".log"
+ [ literalOsPath "remote/web" </> hdir </> toOsPath (serializeKey'' key) <> literalOsPath ".log"
+ , literalOsPath "remote/web" </> hdir </> keyFile key <> literalOsPath ".log"
]
where
hdir = branchHashDir config key
-urlLogExt :: S.ByteString
-urlLogExt = ".log.web"
+urlLogExt :: OsPath
+urlLogExt = literalOsPath ".log.web"
{- Does not work on oldurllogs. -}
-isUrlLog :: RawFilePath -> Bool
-isUrlLog file = urlLogExt `S.isSuffixOf` file
+isUrlLog :: OsPath -> Bool
+isUrlLog file = urlLogExt `OS.isSuffixOf` file
{- The filename of the remote state log for a given key. -}
-remoteStateLogFile :: GitConfig -> Key -> RawFilePath
+remoteStateLogFile :: GitConfig -> Key -> OsPath
remoteStateLogFile config key =
- (branchHashDir config key P.</> keyFile key)
+ (branchHashDir config key </> keyFile key)
<> remoteStateLogExt
-remoteStateLogExt :: S.ByteString
-remoteStateLogExt = ".log.rmt"
+remoteStateLogExt :: OsPath
+remoteStateLogExt = literalOsPath ".log.rmt"
-isRemoteStateLog :: RawFilePath -> Bool
-isRemoteStateLog path = remoteStateLogExt `S.isSuffixOf` path
+isRemoteStateLog :: OsPath -> Bool
+isRemoteStateLog path = remoteStateLogExt `OS.isSuffixOf` path
{- The filename of the chunk log for a given key. -}
-chunkLogFile :: GitConfig -> Key -> RawFilePath
+chunkLogFile :: GitConfig -> Key -> OsPath
chunkLogFile config key =
- (branchHashDir config key P.</> keyFile key)
+ (branchHashDir config key </> keyFile key)
<> chunkLogExt
-chunkLogExt :: S.ByteString
-chunkLogExt = ".log.cnk"
+chunkLogExt :: OsPath
+chunkLogExt = literalOsPath ".log.cnk"
{- The filename of the equivalent keys log for a given key. -}
-equivilantKeysLogFile :: GitConfig -> Key -> RawFilePath
+equivilantKeysLogFile :: GitConfig -> Key -> OsPath
equivilantKeysLogFile config key =
- (branchHashDir config key P.</> keyFile key)
+ (branchHashDir config key </> keyFile key)
<> equivilantKeyLogExt
-equivilantKeyLogExt :: S.ByteString
-equivilantKeyLogExt = ".log.ek"
+equivilantKeyLogExt :: OsPath
+equivilantKeyLogExt = literalOsPath ".log.ek"
-isEquivilantKeyLog :: RawFilePath -> Bool
-isEquivilantKeyLog path = equivilantKeyLogExt `S.isSuffixOf` path
+isEquivilantKeyLog :: OsPath -> Bool
+isEquivilantKeyLog path = equivilantKeyLogExt `OS.isSuffixOf` path
{- The filename of the metadata log for a given key. -}
-metaDataLogFile :: GitConfig -> Key -> RawFilePath
+metaDataLogFile :: GitConfig -> Key -> OsPath
metaDataLogFile config key =
- (branchHashDir config key P.</> keyFile key)
+ (branchHashDir config key </> keyFile key)
<> metaDataLogExt
-metaDataLogExt :: S.ByteString
-metaDataLogExt = ".log.met"
+metaDataLogExt :: OsPath
+metaDataLogExt = literalOsPath ".log.met"
-isMetaDataLog :: RawFilePath -> Bool
-isMetaDataLog path = metaDataLogExt `S.isSuffixOf` path
+isMetaDataLog :: OsPath -> Bool
+isMetaDataLog path = metaDataLogExt `OS.isSuffixOf` path
{- The filename of the remote metadata log for a given key. -}
-remoteMetaDataLogFile :: GitConfig -> Key -> RawFilePath
+remoteMetaDataLogFile :: GitConfig -> Key -> OsPath
remoteMetaDataLogFile config key =
- (branchHashDir config key P.</> keyFile key)
+ (branchHashDir config key </> keyFile key)
<> remoteMetaDataLogExt
-remoteMetaDataLogExt :: S.ByteString
-remoteMetaDataLogExt = ".log.rmet"
+remoteMetaDataLogExt :: OsPath
+remoteMetaDataLogExt = literalOsPath ".log.rmet"
-isRemoteMetaDataLog :: RawFilePath -> Bool
-isRemoteMetaDataLog path = remoteMetaDataLogExt `S.isSuffixOf` path
+isRemoteMetaDataLog :: OsPath -> Bool
+isRemoteMetaDataLog path = remoteMetaDataLogExt `OS.isSuffixOf` path
{- The filename of the remote content identifier log for a given key. -}
-remoteContentIdentifierLogFile :: GitConfig -> Key -> RawFilePath
+remoteContentIdentifierLogFile :: GitConfig -> Key -> OsPath
remoteContentIdentifierLogFile config key =
- (branchHashDir config key P.</> keyFile key)
+ (branchHashDir config key </> keyFile key)
<> remoteContentIdentifierExt
-remoteContentIdentifierExt :: S.ByteString
-remoteContentIdentifierExt = ".log.cid"
+remoteContentIdentifierExt :: OsPath
+remoteContentIdentifierExt = literalOsPath ".log.cid"
-isRemoteContentIdentifierLog :: RawFilePath -> Bool
-isRemoteContentIdentifierLog path = remoteContentIdentifierExt `S.isSuffixOf` path
+isRemoteContentIdentifierLog :: OsPath -> Bool
+isRemoteContentIdentifierLog path = remoteContentIdentifierExt `OS.isSuffixOf` path
{- From an extension and a log filename, get the key that it's a log for. -}
-extLogFileKey :: S.ByteString -> RawFilePath -> Maybe Key
+extLogFileKey :: OsPath -> OsPath -> Maybe Key
extLogFileKey expectedext path
| ext == expectedext = fileKey base
| otherwise = Nothing
where
- file = P.takeFileName path
- (base, ext) = S.splitAt (S.length file - extlen) file
- extlen = S.length expectedext
+ file = takeFileName path
+ (base, ext) = OS.splitAt (OS.length file - extlen) file
+ extlen = OS.length expectedext
{- Converts a url log file into a key.
- (Does not work on oldurlLogs.) -}
-urlLogFileKey :: RawFilePath -> Maybe Key
+urlLogFileKey :: OsPath -> Maybe Key
urlLogFileKey = extLogFileKey urlLogExt
{- Converts a pathname into a key if it's a location log. -}
-locationLogFileKey :: GitConfig -> RawFilePath -> Maybe Key
+locationLogFileKey :: GitConfig -> OsPath -> Maybe Key
locationLogFileKey config path
- | length (splitDirectories (fromRawFilePath path)) /= locationLogFileDepth config = Nothing
- | otherwise = extLogFileKey ".log" path
+ | length (splitDirectories path) /= locationLogFileDepth config = Nothing
+ | otherwise = extLogFileKey (literalOsPath ".log") path
{- Depth of location log files within the git-annex branch.
-
getExportExcluded u = do
logf <- fromRepo $ gitAnnexExportExcludeLog u
liftIO $ catchDefaultIO [] $ exportExcludedParser
- <$> F.readFile (toOsPath logf)
+ <$> F.readFile logf
where
exportExcludedParser :: L.ByteString -> [Git.Tree.TreeItem]
-- | Writes content to a file, replacing the file atomically, and
-- making the new file have whatever permissions the git repository is
-- configured to use. Creates the parent directory when necessary.
-writeLogFile :: RawFilePath -> String -> Annex ()
-writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog (toOsPath f) c
+writeLogFile :: OsPath -> String -> Annex ()
+writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog f c
where
writelog tmp c' = do
- liftIO $ writeFile (fromRawFilePath (fromOsPath tmp)) c'
- setAnnexFilePerm (fromOsPath tmp)
+ liftIO $ writeFile (fromOsPath tmp) c'
+ setAnnexFilePerm tmp
-- | Runs the action with a handle connected to a temp file.
-- The temp file replaces the log file once the action succeeds.
-withLogHandle :: RawFilePath -> (Handle -> Annex a) -> Annex a
+withLogHandle :: OsPath -> (Handle -> Annex a) -> Annex a
withLogHandle f a = do
createAnnexDirectory (parentDir f)
replaceGitAnnexDirFile f $ \tmp ->
where
setup tmp = do
setAnnexFilePerm tmp
- liftIO $ F.openFile (toOsPath tmp) WriteMode
+ liftIO $ F.openFile tmp WriteMode
cleanup h = liftIO $ hClose h
-- | Appends a line to a log file, first locking it to prevent
-- concurrent writers.
-appendLogFile :: RawFilePath -> RawFilePath -> L.ByteString -> Annex ()
+appendLogFile :: OsPath -> OsPath -> L.ByteString -> Annex ()
appendLogFile f lck c =
createDirWhenNeeded f $
withExclusiveLock lck $ do
- liftIO $ F.withFile (toOsPath f) AppendMode $
+ liftIO $ F.withFile f AppendMode $
\h -> L8.hPutStrLn h c
setAnnexFilePerm f
--
-- The file is locked to prevent concurrent writers, and it is written
-- atomically.
-modifyLogFile :: RawFilePath -> RawFilePath -> ([L.ByteString] -> [L.ByteString]) -> Annex ()
+modifyLogFile :: OsPath -> OsPath -> ([L.ByteString] -> [L.ByteString]) -> Annex ()
modifyLogFile f lck modf = withExclusiveLock lck $ do
ls <- liftIO $ fromMaybe []
- <$> tryWhenExists (fileLines <$> F.readFile f')
+ <$> tryWhenExists (fileLines <$> F.readFile f)
let ls' = modf ls
when (ls' /= ls) $
createDirWhenNeeded f $
- viaTmp writelog f' (L8.unlines ls')
+ viaTmp writelog f (L8.unlines ls')
where
- f' = toOsPath f
writelog lf b = do
liftIO $ F.writeFile lf b
- setAnnexFilePerm (fromOsPath lf)
+ setAnnexFilePerm lf
-- | Checks the content of a log file to see if any line matches.
-checkLogFile :: RawFilePath -> RawFilePath -> (L.ByteString -> Bool) -> Annex Bool
+checkLogFile :: OsPath -> OsPath -> (L.ByteString -> Bool) -> Annex Bool
checkLogFile f lck matchf = withSharedLock lck $ bracket setup cleanup go
where
- setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode
+ setup = liftIO $ tryWhenExists $ F.openFile f ReadMode
cleanup Nothing = noop
cleanup (Just h) = liftIO $ hClose h
go Nothing = return False
return r
-- | Folds a function over lines of a log file to calculate a value.
-calcLogFile :: RawFilePath -> RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t
+calcLogFile :: OsPath -> OsPath -> t -> (L.ByteString -> t -> t) -> Annex t
calcLogFile f lck start update =
withSharedLock lck $ calcLogFileUnsafe f start update
-- | Unsafe version that does not do locking.
-calcLogFileUnsafe :: RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t
+calcLogFileUnsafe :: OsPath -> t -> (L.ByteString -> t -> t) -> Annex t
calcLogFileUnsafe f start update = bracket setup cleanup go
where
- setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode
+ setup = liftIO $ tryWhenExists $ F.openFile f ReadMode
cleanup Nothing = noop
cleanup (Just h) = liftIO $ hClose h
go Nothing = return start
--
-- Locking is used to prevent writes to to the log file while this
-- is running.
-streamLogFile :: RawFilePath -> RawFilePath -> Annex () -> (String -> Annex ()) -> Annex ()
+streamLogFile :: OsPath -> OsPath -> Annex () -> (String -> Annex ()) -> Annex ()
streamLogFile f lck finalizer processor =
withExclusiveLock lck $ do
streamLogFileUnsafe f finalizer processor
- liftIO $ F.writeFile' (toOsPath f) mempty
+ liftIO $ F.writeFile' f mempty
setAnnexFilePerm f
-- Unsafe version that does not do locking, and does not empty the file
-- at the end.
-streamLogFileUnsafe :: RawFilePath -> Annex () -> (String -> Annex ()) -> Annex ()
+streamLogFileUnsafe :: OsPath -> Annex () -> (String -> Annex ()) -> Annex ()
streamLogFileUnsafe f finalizer processor = bracketOnError setup cleanup go
where
- setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode
+ setup = liftIO $ tryWhenExists $ F.openFile f ReadMode
cleanup Nothing = noop
cleanup (Just h) = liftIO $ hClose h
go Nothing = finalizer
liftIO $ hClose h
finalizer
-createDirWhenNeeded :: RawFilePath -> Annex () -> Annex ()
+createDirWhenNeeded :: OsPath -> Annex () -> Annex ()
createDirWhenNeeded f a = a `catchNonAsync` \_e -> do
-- Most of the time, the directory will exist, so this is only
-- done if writing the file fails.
import Git.Fsck
import Git.Types
import Logs.File
-import qualified Utility.RawFilePath as R
import qualified Data.Set as S
case serializeFsckResults fsckresults of
Just s -> store s logfile
Nothing -> liftIO $
- removeWhenExistsWith R.removeLink logfile
+ removeWhenExistsWith removeFile logfile
where
store s logfile = writeLogFile logfile s
readFsckResults u = do
logfile <- fromRepo $ gitAnnexFsckResultsLog u
liftIO $ catchDefaultIO (FsckFoundMissing S.empty False) $
- deserializeFsckResults <$> readFile (fromRawFilePath logfile)
+ deserializeFsckResults <$> readFile (fromOsPath logfile)
deserializeFsckResults :: String -> FsckResults
deserializeFsckResults = deserialize . lines
in if S.null s then FsckFailed else FsckFoundMissing s t
clearFsckResults :: UUID -> Annex ()
-clearFsckResults = liftIO . removeWhenExistsWith R.removeLink
+clearFsckResults = liftIO . removeWhenExistsWith removeFile
<=< fromRepo . gitAnnexFsckResultsLog
map (toUUID . fromLogInfo . info)
(filterPresent (parseLog l))
-getLoggedLocations :: (RawFilePath -> Annex [LogInfo]) -> Key -> Annex [UUID]
+getLoggedLocations :: (OsPath -> Annex [LogInfo]) -> Key -> Annex [UUID]
getLoggedLocations getter key = do
config <- Annex.getGitConfig
locs <- map (toUUID . fromLogInfo) <$> getter (locationLogFile config key)
changedlocs _ _ _ Nothing = pure (S.empty, S.empty)
overLocationLogsHelper
- :: ((RawFilePath -> Maybe Key) -> (Annex (FileContents Key b) -> Annex v) -> Annex a)
- -> ((Maybe L.ByteString -> [UUID]) -> Key -> RawFilePath -> Maybe (L.ByteString, Maybe b) -> Annex u)
+ :: ((OsPath -> Maybe Key) -> (Annex (FileContents Key b) -> Annex v) -> Annex a)
+ -> ((Maybe L.ByteString -> [UUID]) -> Key -> OsPath -> Maybe (L.ByteString, Maybe b) -> Annex u)
-> Bool
-> v
-> (Annex (FileContents Key b) -> Annex v -> Annex v)
getCurrentMetaData :: Key -> Annex MetaData
getCurrentMetaData = getCurrentMetaData' metaDataLogFile
-getCurrentMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> Annex MetaData
+getCurrentMetaData' :: (GitConfig -> Key -> OsPath) -> Key -> Annex MetaData
getCurrentMetaData' getlogfile k = do
config <- Annex.getGitConfig
parseCurrentMetaData <$> Annex.Branch.get (getlogfile config k)
addMetaData :: Key -> MetaData -> Annex ()
addMetaData = addMetaData' (Annex.Branch.RegardingUUID []) metaDataLogFile
-addMetaData' :: Annex.Branch.RegardingUUID -> (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> Annex ()
+addMetaData' :: Annex.Branch.RegardingUUID -> (GitConfig -> Key -> OsPath) -> Key -> MetaData -> Annex ()
addMetaData' ru getlogfile k metadata =
addMetaDataClocked' ru getlogfile k metadata =<< currentVectorClock
addMetaDataClocked :: Key -> MetaData -> CandidateVectorClock -> Annex ()
addMetaDataClocked = addMetaDataClocked' (Annex.Branch.RegardingUUID []) metaDataLogFile
-addMetaDataClocked' :: Annex.Branch.RegardingUUID -> (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> CandidateVectorClock -> Annex ()
+addMetaDataClocked' :: Annex.Branch.RegardingUUID -> (GitConfig -> Key -> OsPath) -> Key -> MetaData -> CandidateVectorClock -> Annex ()
addMetaDataClocked' ru getlogfile k d@(MetaData m) c
| d == emptyMetaData = noop
| otherwise = do
(const $ buildLog l)
return True
-readLog :: RawFilePath -> Annex (Log MetaData)
+readLog :: OsPath -> Annex (Log MetaData)
readLog = parseLog <$$> Annex.Branch.get
import Logs.File
import Logs
import Annex.CatFile
+import qualified Utility.OsString as OS
-import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Control.Concurrent.STM
-import System.FilePath.ByteString as P
-- | What to use to record a migration. This should be the same Sha that is
-- used to as the content of the annexed file in the HEAD branch.
n <- readTVar nv
let !n' = succ n
writeTVar nv n'
- return (asTopFilePath (encodeBS (show n')))
+ return (asTopFilePath (toOsPath (show n')))
let rec h r = liftIO $ sendMkTree h
(fromTreeItemType TreeFile)
BlobObject
n <- liftIO $ atomically $ readTVar nv
when (n > 0) $ do
treesha <- liftIO $ flip recordTree g $ Tree
- [ RecordedSubTree (asTopFilePath "old") oldt []
- , RecordedSubTree (asTopFilePath "new") newt []
+ [ RecordedSubTree (asTopFilePath (literalOsPath "old")) oldt []
+ , RecordedSubTree (asTopFilePath (literalOsPath "new")) newt []
]
commitsha <- Annex.Branch.rememberTreeish treesha
(asTopFilePath migrationTreeGraftPoint)
(stoppoint, toskip) <- getPerformedMigrations
(l, cleanup) <- inRepo $ getGitLog branchsha
(if incremental then stoppoint else Nothing)
- [fromRawFilePath migrationTreeGraftPoint]
+ [fromOsPath migrationTreeGraftPoint]
-- Need to follow because migrate.tree is grafted in
-- and then deleted, and normally git log stops when a file
-- gets deleted.
go toskip c
| newref c `elem` nullShas = return ()
| changed c `elem` toskip = return ()
- | not ("/new/" `B.isInfixOf` newfile) = return ()
+ | not (literalOsPath "/new/" `OS.isInfixOf` newfile) = return ()
| otherwise =
catKey (newref c) >>= \case
Nothing -> return ()
Nothing -> return ()
Just oldkey -> a oldkey newkey
where
- newfile = toRawFilePath (changedfile c)
+ newfile = changedfile c
oldfile = migrationTreeGraftPoint
- P.</> "old"
- P.</> P.takeBaseName (fromInternalGitPath newfile)
+ </> literalOsPath "old"
+ </> takeBaseName (fromInternalGitPath newfile)
oldfileref = branchFileRef (changed c) oldfile
getPerformedMigrations :: Annex (Maybe Sha, [Sha])
setLog requiredContentLog u expr
Annex.changeState $ \st -> st { Annex.requiredcontentmap = Nothing }
-setLog :: RawFilePath -> UUID -> PreferredContentExpression -> Annex ()
+setLog :: OsPath -> UUID -> PreferredContentExpression -> Annex ()
setLog logfile uuid@(UUID _) val = do
c <- currentVectorClock
Annex.Branch.change (Annex.Branch.RegardingUUID [uuid]) logfile $
import qualified Data.ByteString.Lazy as L
{- Adds to the log, removing any LogLines that are obsoleted. -}
-addLog :: Annex.Branch.RegardingUUID -> RawFilePath -> LogStatus -> LogInfo -> Annex ()
+addLog :: Annex.Branch.RegardingUUID -> OsPath -> LogStatus -> LogInfo -> Annex ()
addLog ru file logstatus loginfo =
addLog' ru file logstatus loginfo =<< currentVectorClock
-addLog' :: Annex.Branch.RegardingUUID -> RawFilePath -> LogStatus -> LogInfo -> CandidateVectorClock -> Annex ()
+addLog' :: Annex.Branch.RegardingUUID -> OsPath -> LogStatus -> LogInfo -> CandidateVectorClock -> Annex ()
addLog' ru file logstatus loginfo c =
Annex.Branch.changeOrAppend ru file $ \b ->
let old = parseLog b
- When the log was changed, the onchange action is run (with the journal
- still locked to prevent any concurrent changes) and True is returned.
-}
-maybeAddLog :: Annex.Branch.RegardingUUID -> RawFilePath -> LogStatus -> LogInfo -> Annex () -> Annex Bool
+maybeAddLog :: Annex.Branch.RegardingUUID -> OsPath -> LogStatus -> LogInfo -> Annex () -> Annex Bool
maybeAddLog ru file logstatus loginfo onchange = do
c <- currentVectorClock
let f = \b ->
{- Reads a log file.
- Note that the LogLines returned may be in any order. -}
-readLog :: RawFilePath -> Annex [LogLine]
+readLog :: OsPath -> Annex [LogLine]
readLog = parseLog <$$> Annex.Branch.get
{- Reads a log and returns only the info that is still present. -}
-presentLogInfo :: RawFilePath -> Annex [LogInfo]
+presentLogInfo :: OsPath -> Annex [LogInfo]
presentLogInfo file = map info . filterPresent <$> readLog file
{- Reads a log and returns only the info that is no longer present. -}
-notPresentLogInfo :: RawFilePath -> Annex [LogInfo]
+notPresentLogInfo :: OsPath -> Annex [LogInfo]
notPresentLogInfo file = map info . filterNotPresent <$> readLog file
{- Reads a historical version of a log and returns the info that was in
-
- The date is formatted as shown in gitrevisions man page.
-}
-historicalLogInfo :: RefDate -> RawFilePath -> Annex [LogInfo]
+historicalLogInfo :: RefDate -> OsPath -> Annex [LogInfo]
historicalLogInfo refdate file = parseLogInfo
<$> Annex.Branch.getHistorical refdate file
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
-import qualified Utility.RawFilePath as R
-- | Log a file whose pointer needs to be restaged in git.
-- The content of the file may not be a pointer, if it is populated with
lckf <- fromRepo gitAnnexRestageLock
withExclusiveLock lckf $ liftIO $
- whenM (R.doesPathExist logf) $
- ifM (R.doesPathExist oldf)
+ whenM (doesPathExist logf) $
+ ifM (doesPathExist oldf)
( do
- h <- F.openFile (toOsPath oldf) AppendMode
- hPutStr h =<< readFile (fromRawFilePath logf)
+ h <- F.openFile oldf AppendMode
+ hPutStr h =<< readFile (fromOsPath logf)
hClose h
- liftIO $ removeWhenExistsWith R.removeLink logf
+ liftIO $ removeWhenExistsWith removeFile logf
, moveFile logf oldf
)
Just (f, ic) -> processor f ic
Nothing -> noop
- liftIO $ removeWhenExistsWith R.removeLink oldf
+ liftIO $ removeWhenExistsWith removeFile oldf
-- | Calculate over both the current restage log, and also over the old
-- one if it had started to be processed but did not get finished due
Nothing -> v
formatRestageLog :: TopFilePath -> InodeCache -> S.ByteString
-formatRestageLog f ic = encodeBS (showInodeCache ic) <> ":" <> getTopFilePath f
+formatRestageLog f ic =
+ encodeBS (showInodeCache ic) <> ":" <> fromOsPath (getTopFilePath f)
parseRestageLog :: String -> Maybe (TopFilePath, InodeCache)
parseRestageLog l =
let (ics, f) = separate (== ':') l
in do
ic <- readInodeCache ics
- return (asTopFilePath (toRawFilePath f), ic)
+ return (asTopFilePath (toOsPath f), ic)
getLastRunTimes :: Annex (M.Map ScheduledActivity LocalTime)
getLastRunTimes = do
- f <- fromRawFilePath <$> fromRepo gitAnnexScheduleState
+ f <- fromOsPath <$> fromRepo gitAnnexScheduleState
liftIO $ fromMaybe M.empty
<$> catchDefaultIO Nothing (readish <$> readFile f)
import qualified Data.Set as S
-readLog :: (Ord v, SingleValueSerializable v) => RawFilePath -> Annex (Log v)
+readLog :: (Ord v, SingleValueSerializable v) => OsPath -> Annex (Log v)
readLog = parseLog <$$> Annex.Branch.get
-getLog :: (Ord v, SingleValueSerializable v) => RawFilePath -> Annex (Maybe v)
+getLog :: (Ord v, SingleValueSerializable v) => OsPath -> Annex (Maybe v)
getLog = newestValue <$$> readLog
-setLog :: (Ord v, SingleValueSerializable v) => Annex.Branch.RegardingUUID -> RawFilePath -> v -> Annex ()
+setLog :: (Ord v, SingleValueSerializable v) => Annex.Branch.RegardingUUID -> OsPath -> v -> Annex ()
setLog ru f v = do
c <- currentVectorClock
Annex.Branch.change ru f $ \old ->
logf <- fromRepo gitAnnexSmudgeLog
lckf <- fromRepo gitAnnexSmudgeLock
appendLogFile logf lckf $ L.fromStrict $
- serializeKey' k <> " " <> getTopFilePath f
+ serializeKey' k <> " " <> fromOsPath (getTopFilePath f)
-- | Streams all smudged files, and then empties the log at the end.
--
let (ks, f) = separate (== ' ') l
in do
k <- deserializeKey ks
- return (k, asTopFilePath (toRawFilePath f))
+ return (k, asTopFilePath (toOsPath f))
import Annex.LockPool
import Utility.TimeStamp
import Logs.File
-import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
+import qualified Utility.OsString as OS
#ifndef mingw32_HOST_OS
import Annex.Perms
#endif
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Control.Concurrent.STM
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as B8
-import qualified System.FilePath.ByteString as P
describeTransfer :: Git.Quote.QuotePath -> Transfer -> TransferInfo -> String
describeTransfer qp t info = unwords
- appropriate permissions, which should be run after locking the transfer
- lock file, but before using the callback, and a TVar that can be used to
- read the number of bytes processed so far. -}
-mkProgressUpdater :: Transfer -> TransferInfo -> RawFilePath -> Annex (MeterUpdate, Annex (), TVar (Maybe BytesProcessed))
+mkProgressUpdater :: Transfer -> TransferInfo -> OsPath -> Annex (MeterUpdate, Annex (), TVar (Maybe BytesProcessed))
mkProgressUpdater t info tfile = do
- let createtfile = void $ tryNonAsync $ writeTransferInfoFile info tfile
+ let createtfile = void $ tryNonAsync $
+ writeTransferInfoFile info tfile
tvar <- liftIO $ newTVarIO Nothing
loggedtvar <- liftIO $ newTVarIO 0
- return (liftIO . updater (fromRawFilePath tfile) tvar loggedtvar, createtfile, tvar)
+ return (liftIO . updater tvar loggedtvar, createtfile, tvar)
where
- updater tfile' tvar loggedtvar new = do
+ updater tvar loggedtvar new = do
old <- atomically $ swapTVar tvar (Just new)
let oldbytes = maybe 0 fromBytesProcessed old
let newbytes = fromBytesProcessed new
when (newbytes - oldbytes >= mindelta) $ do
let info' = info { bytesComplete = Just newbytes }
- _ <- tryIO $ updateTransferInfoFile info' tfile'
+ _ <- tryIO $ updateTransferInfoFile info' tfile
atomically $ writeTVar loggedtvar newbytes
{- The minimum change in bytesComplete that is worth
checkTransfer t = debugLocks $ do
(tfile, lck, moldlck) <- fromRepo $ transferFileAndLockFile t
let deletestale = do
- void $ tryIO $ R.removeLink tfile
- void $ tryIO $ R.removeLink lck
- maybe noop (void . tryIO . R.removeLink) moldlck
+ void $ tryIO $ removeFile tfile
+ void $ tryIO $ removeFile lck
+ maybe noop (void . tryIO . removeFile) moldlck
#ifndef mingw32_HOST_OS
v <- getLockStatus lck
v' <- case (moldlck, v) of
removeFailedTransfer :: Transfer -> Annex ()
removeFailedTransfer t = do
f <- fromRepo $ failedTransferFile t
- liftIO $ void $ tryIO $ R.removeLink f
+ liftIO $ void $ tryIO $ removeFile f
recordFailedTransfer :: Transfer -> TransferInfo -> Annex ()
recordFailedTransfer t info = do
- At some point in the future, when old git-annex processes are no longer
- a concern, this complication can be removed.
-}
-transferFileAndLockFile :: Transfer -> Git.Repo -> (RawFilePath, RawFilePath, Maybe RawFilePath)
+transferFileAndLockFile :: Transfer -> Git.Repo -> (OsPath, OsPath, Maybe OsPath)
transferFileAndLockFile (Transfer direction u kd) r =
case direction of
Upload -> (transferfile, uuidlockfile, Nothing)
Download -> (transferfile, nouuidlockfile, Just uuidlockfile)
where
td = transferDir direction r
- fu = B8.filter (/= '/') (fromUUID u)
+ fu = OS.filter (/= unsafeFromChar '/') (fromUUID u)
kf = keyFile (mkKey (const kd))
- lckkf = "lck." <> kf
- transferfile = td P.</> fu P.</> kf
- uuidlockfile = td P.</> fu P.</> lckkf
- nouuidlockfile = td P.</> "lck" P.</> lckkf
+ lckkf = literalOsPath "lck." <> kf
+ transferfile = td </> fu </> kf
+ uuidlockfile = td </> fu </> lckkf
+ nouuidlockfile = td </> literalOsPath "lck" </> lckkf
{- The transfer information file to use to record a failed Transfer -}
-failedTransferFile :: Transfer -> Git.Repo -> RawFilePath
+failedTransferFile :: Transfer -> Git.Repo -> OsPath
failedTransferFile (Transfer direction u kd) r =
failedTransferDir u direction r
- P.</> keyFile (mkKey (const kd))
+ </> keyFile (mkKey (const kd))
{- Parses a transfer information filename to a Transfer. -}
-parseTransferFile :: RawFilePath -> Maybe Transfer
+parseTransferFile :: OsPath -> Maybe Transfer
parseTransferFile file
- | "lck." `B.isPrefixOf` P.takeFileName file = Nothing
+ | literalOsPath "lck." `OS.isPrefixOf` takeFileName file = Nothing
| otherwise = case drop (length bits - 3) bits of
[direction, u, key] -> Transfer
- <$> parseDirection direction
+ <$> parseDirection (fromOsPath direction)
<*> pure (toUUID u)
<*> fmap (fromKey id) (fileKey key)
_ -> Nothing
where
- bits = P.splitDirectories file
+ bits = splitDirectories file
-writeTransferInfoFile :: TransferInfo -> RawFilePath -> Annex ()
+writeTransferInfoFile :: TransferInfo -> OsPath -> Annex ()
writeTransferInfoFile info tfile = writeLogFile tfile $ writeTransferInfo info
-- The file keeps whatever permissions it has, so should be used only
-- after it's been created with the right perms by writeTransferInfoFile.
-updateTransferInfoFile :: TransferInfo -> FilePath -> IO ()
-updateTransferInfoFile info tfile = writeFile tfile $ writeTransferInfo info
+updateTransferInfoFile :: TransferInfo -> OsPath -> IO ()
+updateTransferInfoFile info tfile =
+ writeFile (fromOsPath tfile) $ writeTransferInfo info
{- File format is a header line containing the startedTime and any
- bytesComplete value. Followed by a newline and the associatedFile.
#endif
-- comes last; arbitrary content
, let AssociatedFile afile = associatedFile info
- in maybe "" fromRawFilePath afile
+ in maybe "" fromOsPath afile
]
-readTransferInfoFile :: Maybe PID -> RawFilePath -> IO (Maybe TransferInfo)
+readTransferInfoFile :: Maybe PID -> OsPath -> IO (Maybe TransferInfo)
readTransferInfoFile mpid tfile = catchDefaultIO Nothing $
- readTransferInfo mpid . decodeBS <$> F.readFile' (toOsPath tfile)
+ readTransferInfo mpid . decodeBS <$> F.readFile' tfile
readTransferInfo :: Maybe PID -> String -> Maybe TransferInfo
readTransferInfo mpid s = TransferInfo
<*> pure Nothing
<*> pure Nothing
<*> bytes
- <*> pure (AssociatedFile (if null filename then Nothing else Just (toRawFilePath filename)))
+ <*> pure af
<*> pure False
where
+ af = AssociatedFile $
+ if null filename
+ then Nothing
+ else Just (toOsPath filename)
#ifdef mingw32_HOST_OS
(firstliner, otherlines) = separate (== '\n') s
(secondliner, rest) = separate (== '\n') otherlines
firstline = dropWhileEnd (== '\r') firstliner
secondline = dropWhileEnd (== '\r') secondliner
- secondline =
mpid' = readish secondline
#else
(firstline, rest) = separate (== '\n') s
else pure Nothing -- not failure
{- The directory holding transfer information files for a given Direction. -}
-transferDir :: Direction -> Git.Repo -> RawFilePath
-transferDir direction r = gitAnnexTransferDir r P.</> formatDirection direction
+transferDir :: Direction -> Git.Repo -> OsPath
+transferDir direction r =
+ gitAnnexTransferDir r
+ </> toOsPath (formatDirection direction)
{- The directory holding failed transfer information files for a given
- Direction and UUID -}
-failedTransferDir :: UUID -> Direction -> Git.Repo -> RawFilePath
+failedTransferDir :: UUID -> Direction -> Git.Repo -> OsPath
failedTransferDir u direction r = gitAnnexTransferDir r
- P.</> "failed"
- P.</> formatDirection direction
- P.</> B8.filter (/= '/') (fromUUID u)
+ </> literalOsPath "failed"
+ </> toOsPath (formatDirection direction)
+ </> OS.filter (/= unsafeFromChar '/') (fromUUID u)
prop_read_write_transferinfo :: TransferInfo -> Bool
prop_read_write_transferinfo info
import qualified Data.Attoparsec.ByteString.Lazy as A
import qualified Data.Attoparsec.ByteString.Char8 as A8
-transitionsLog :: RawFilePath
-transitionsLog = "transitions.log"
+transitionsLog :: OsPath
+transitionsLog = literalOsPath "transitions.log"
data Transition
= ForgetGitHistory
{- Typically ran with Annex.Branch.change, but we can't import Annex.Branch
- here since it depends on this module. -}
-recordTransitions :: (RawFilePath -> (L.ByteString -> Builder) -> Annex ()) -> Transitions -> Annex ()
+recordTransitions :: (OsPath -> (L.ByteString -> Builder) -> Annex ()) -> Transitions -> Annex ()
recordTransitions changer t = changer transitionsLog $
buildTransitions . S.union t . parseTransitionsStrictly "local"
where
oldts _old@(_, ts) _new@(int, _) = (int, ts)
-updateUnusedLog :: RawFilePath -> UnusedMap -> Annex ()
+updateUnusedLog :: OsPath -> UnusedMap -> Annex ()
updateUnusedLog prefix m = do
oldl <- readUnusedLog prefix
newl <- preserveTimestamps oldl . flip map2log m <$> liftIO getPOSIXTime
writeUnusedLog prefix newl
-writeUnusedLog :: RawFilePath -> UnusedLog -> Annex ()
+writeUnusedLog :: OsPath -> UnusedLog -> Annex ()
writeUnusedLog prefix l = do
logfile <- fromRepo $ gitAnnexUnusedLog prefix
writeLogFile logfile $ unlines $ map format $ M.toList l
format (k, (i, Just t)) = show i ++ " " ++ serializeKey k ++ " " ++ show t
format (k, (i, Nothing)) = show i ++ " " ++ serializeKey k
-readUnusedLog :: RawFilePath -> Annex UnusedLog
+readUnusedLog :: OsPath -> Annex UnusedLog
readUnusedLog prefix = do
f <- fromRepo (gitAnnexUnusedLog prefix)
- ifM (liftIO $ doesFileExist (fromRawFilePath f))
+ ifM (liftIO $ doesFileExist f)
( M.fromList . mapMaybe (parse . decodeBS) . fileLines'
- <$> liftIO (F.readFile' (toOsPath f))
+ <$> liftIO (F.readFile' f)
, return M.empty
)
where
skey = reverse rskey
ts = reverse rts
-readUnusedMap :: RawFilePath -> Annex UnusedMap
+readUnusedMap :: OsPath -> Annex UnusedMap
readUnusedMap = log2map <$$> readUnusedLog
-dateUnusedLog :: RawFilePath -> Annex (Maybe UTCTime)
+dateUnusedLog :: OsPath -> Annex (Maybe UTCTime)
dateUnusedLog prefix = do
f <- fromRepo $ gitAnnexUnusedLog prefix
- liftIO $ catchMaybeIO $ getModificationTime $ fromRawFilePath f
+ liftIO $ catchMaybeIO $ getModificationTime f
{- Set of unused keys. This is cached for speed. -}
unusedKeys :: Annex (S.Set Key)
=<< Annex.getState Annex.unusedkeys
unusedKeys' :: Annex [Key]
-unusedKeys' = M.keys <$> readUnusedLog ""
+unusedKeys' = M.keys <$> readUnusedLog (literalOsPath "")
setUnusedKeys :: [Key] -> Annex (S.Set Key)
setUnusedKeys ks = do
readUpgradeLog :: Annex [(RepoVersion, POSIXTime)]
readUpgradeLog = do
logfile <- fromRepo gitAnnexUpgradeLog
- ifM (liftIO $ doesFileExist (fromRawFilePath logfile))
+ ifM (liftIO $ doesFileExist logfile)
( mapMaybe (parse . decodeBS) . fileLines'
- <$> liftIO (F.readFile' (toOsPath logfile))
+ <$> liftIO (F.readFile' logfile)
, return []
)
where
recentViews :: Annex [View]
recentViews = do
- f <- fromRawFilePath <$> fromRepo gitAnnexViewLog
+ f <- fromOsPath <$> fromRepo gitAnnexViewLog
liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFile f)
{- Gets the currently checked out view, if there is one.
toplevelMsg :: (Semigroup t, IsString t) => t -> t
toplevelMsg s = fromString "git-annex: " <> s
-toplevelFileProblem :: Bool -> MessageId -> StringContainingQuotedPath -> String -> RawFilePath -> Maybe Key -> SeekInput -> Annex ()
+toplevelFileProblem :: Bool -> MessageId -> StringContainingQuotedPath -> String -> OsPath -> Maybe Key -> SeekInput -> Annex ()
toplevelFileProblem makeway messageid msg action file mkey si = do
maybeShowJSON' $ JSON.start action (Just file) mkey si
maybeShowJSON' $ JSON.messageid messageid
import Control.Applicative
import qualified Data.Map as M
import qualified Data.Vector as V
+import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Aeson.KeyMap as HM
import System.IO
import Utility.Metered
import Utility.Percentage
import Utility.Aeson
-import Utility.FileSystemEncoding
+import Utility.OsPath
import Types.Messages
-- A global lock to avoid concurrent threads emitting json at the same time.
none :: JSONBuilder
none = id
-start :: String -> Maybe RawFilePath -> Maybe Key -> SeekInput -> JSONBuilder
+start :: String -> Maybe OsPath -> Maybe Key -> SeekInput -> JSONBuilder
start command file key si _ = case j of
Object o -> Just (o, False)
_ -> Nothing
j = toJSON' $ JSONActionItem
{ itemCommand = Just command
, itemKey = key
- , itemFile = fromRawFilePath <$> file
+ , itemFile = file
, itemUUID = Nothing
, itemFields = Nothing :: Maybe Bool
, itemSeekInput = si
j = toJSON' $ JSONActionItem
{ itemCommand = Just command
, itemKey = actionItemKey ai
- , itemFile = fromRawFilePath <$> actionItemFile ai
+ , itemFile = actionItemFile ai
, itemUUID = actionItemUUID ai
, itemFields = Nothing :: Maybe Bool
, itemSeekInput = si
data JSONActionItem a = JSONActionItem
{ itemCommand :: Maybe String
, itemKey :: Maybe Key
- , itemFile :: Maybe FilePath
+ , itemFile :: Maybe OsPath
, itemUUID :: Maybe UUID
, itemFields :: Maybe a
, itemSeekInput :: SeekInput
Just k -> Just $ "key" .= toJSON' k
Nothing -> Nothing
, case itemFile i of
- Just f -> Just $ "file" .= toJSON' f
+ Just f ->
+ let f' = (fromOsPath f) :: S.ByteString
+ in Just $ "file" .= toJSON' f'
Nothing -> Nothing
, case itemFields i of
Just f -> Just $ "fields" .= toJSON' f
parseJSON (Object v) = JSONActionItem
<$> (v .:? "command")
<*> (maybe (return Nothing) parseJSON =<< (v .:? "key"))
- <*> (v .:? "file")
+ <*> (fmap stringToOsPath <$> (v .:? "file"))
<*> (v .:? "uuid")
<*> (v .:? "fields")
-- ^ fields is used for metadata, which is currently the
- This allows uploads of keys without size to still have progress
- displayed.
-}
-data KeySizer = KeySizer Key (Annex (Maybe RawFilePath))
+data KeySizer = KeySizer Key (Annex (Maybe OsPath))
instance MeterSize KeySizer where
getMeterSize (KeySizer k getsrcfile) = case fromKey keySize k of
minratelimit = min consoleratelimit jsonratelimit
{- Poll file size to display meter. -}
-meteredFile :: RawFilePath -> Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a
+meteredFile :: OsPath -> Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a
meteredFile file combinemeterupdate key a =
metered combinemeterupdate key Nothing $ \_ p ->
watchFileSize file p a
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module P2P.Address where
import qualified Annex
addrs <- loadP2PAddresses
unless (addr `elem` addrs) $ do
let s = unlines $ map formatP2PAddress (addr:addrs)
- let tmpnam = p2pAddressCredsFile ++ ".new"
+ let tmpnam = p2pAddressCredsFile <> literalOsPath ".new"
writeCreds s tmpnam
tmpf <- credsFile tmpnam
destf <- credsFile p2pAddressCredsFile
-- This may be run by root, so make the creds file
-- and directory have the same owner and group as
-- the git repository directory has.
- st <- liftIO . R.getFileStatus . toRawFilePath
- =<< Annex.fromRepo repoLocation
- let fixowner f = R.setOwnerAndGroup (toRawFilePath f) (fileOwner st) (fileGroup st)
+ st <- liftIO . R.getFileStatus . fromOsPath
+ =<< Annex.fromRepo repoPath
+ let fixowner f = R.setOwnerAndGroup (fromOsPath f) (fileOwner st) (fileGroup st)
liftIO $ do
fixowner tmpf
fixowner (takeDirectory tmpf)
fixowner (takeDirectory (takeDirectory tmpf))
renameFile tmpf destf
-p2pAddressCredsFile :: FilePath
-p2pAddressCredsFile = "p2paddrs"
+p2pAddressCredsFile :: OsPath
+p2pAddressCredsFile = literalOsPath "p2paddrs"
torAppName :: AppName
torAppName = "tor-annex"
import Annex.Content
import Annex.Transfer
import Annex.ChangedRefs
+import Annex.Verify
import P2P.Protocol
import P2P.IO
import Logs.Location
import Types.NumCopies
import Utility.Metered
import Utility.MonotonicClock
-import Annex.Verify
+import qualified Utility.FileIO as F
import Control.Monad.Free
import Control.Concurrent.STM
size <- liftIO $ catchDefaultIO 0 $ getFileSize tmp
runner (next (Len size))
FileSize f next -> do
- size <- liftIO $ catchDefaultIO 0 $ getFileSize (toRawFilePath f)
+ size <- liftIO $ catchDefaultIO 0 $ getFileSize f
runner (next (Len size))
ContentSize k next -> do
let getsize = liftIO . catchMaybeIO . getFileSize
let runtransfer ti =
Right <$> transfer download' k af Nothing (\p ->
logStatusAfter NoLiveUpdate k $ getViaTmp rsp DefaultVerify k af Nothing $ \tmp ->
- storefile (fromRawFilePath tmp) o l getb iv validitycheck p ti)
+ storefile tmp o l getb iv validitycheck p ti)
let fallback = return $ Left $
ProtoFailureMessage "transfer already in progress, or unable to take transfer lock"
checktransfer runtransfer fallback
v <- runner getb
case v of
Right b -> do
- liftIO $ withBinaryFile dest ReadWriteMode $ \h -> do
+ liftIO $ F.withBinaryFile dest ReadWriteMode $ \h -> do
p' <- resumeVerifyFromOffset o incrementalverifier p h
meteredWrite p' (writeVerifyChunk incrementalverifier h) b
indicatetransferred ti
rightsize <- do
- sz <- liftIO $ getFileSize (toRawFilePath dest)
+ sz <- liftIO $ getFileSize dest
return (toInteger sz == l + o)
runner validitycheck >>= \case
Nothing -> return (True, UnVerified)
Just True -> return (True, Verified)
Just False -> do
- verificationOfContentFailed (toRawFilePath dest)
+ verificationOfContentFailed dest
return (False, UnVerified)
| otherwise -> return (False, UnVerified)
Nothing -> return (rightsize, UnVerified)
sinkfile f (Offset o) checkchanged sender p ti = bracket setup cleanup go
where
- setup = liftIO $ openBinaryFile f ReadMode
+ setup = liftIO $ F.openBinaryFile f ReadMode
cleanup = liftIO . hClose
go h = do
let p' = offsetMeterUpdate p (toBytesProcessed o)
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module P2P.Auth where
import Annex.Common
let d = unlines $ map (T.unpack . fromAuthToken) (t:ts)
writeCreds d p2pAuthCredsFile
-p2pAuthCredsFile :: FilePath
-p2pAuthCredsFile = "p2pauth"
+p2pAuthCredsFile :: OsPath
+p2pAuthCredsFile = literalOsPath "p2pauth"
-- | Loads the AuthToken to use when connecting with a given P2P address.
--
(T.unpack $ fromAuthToken t)
(addressCredsFile addr)
-addressCredsFile :: P2PAddress -> FilePath
+addressCredsFile :: P2PAddress -> OsPath
-- We can omit the port and just use the onion address for the creds file,
-- because any given tor hidden service runs on a single port and has a
-- unique onion address.
-addressCredsFile (TorAnnex (OnionAddress onionaddr) _port) = onionaddr
+addressCredsFile (TorAnnex (OnionAddress onionaddr) _port) =
+ toOsPath onionaddr
import Utility.Url (BasicAuth(..))
import Utility.HumanTime
import Utility.STM
+import qualified Utility.FileIO as F
import qualified Git.Credential as Git
import Servant hiding (BasicAuthData(..))
-> Key
-> Maybe Offset
-> AssociatedFile
- -> FilePath
+ -> OsPath
-> FileSize
-> Annex Bool
-- ^ Called after sending the file to check if it's valid.
liftIO $ atomically $ takeTMVar checkv
validitycheck >>= liftIO . atomically . putTMVar checkresultv
checkerthread <- liftIO . async =<< forkState checker
- v <- liftIO $ withBinaryFile contentfile ReadMode $ \h -> do
+ v <- liftIO $ F.withBinaryFile contentfile ReadMode $ \h -> do
when (offset /= 0) $
hSeek h AbsoluteSeek offset
withClientM (cli (stream h checkv checkresultv)) clientenv return
newtype B64Key = B64Key Key
deriving (Show)
-newtype B64FilePath = B64FilePath RawFilePath
+newtype B64FilePath = B64FilePath OsPath
deriving (Show)
associatedFileToB64FilePath :: AssociatedFile -> Maybe B64FilePath
Left err -> Left err
instance ToHttpApiData B64FilePath where
- toUrlPiece (B64FilePath f) = encodeB64Text f
+ toUrlPiece (B64FilePath f) = encodeB64Text (fromOsPath f)
instance FromHttpApiData B64FilePath where
parseUrlPiece t = case decodeB64Text t of
- Right b -> Right (B64FilePath b)
+ Right b -> Right (B64FilePath (toOsPath b))
Left err -> Left err
instance ToHttpApiData Offset where
import Utility.MonotonicClock
import Types.UUID
import Annex.ChangedRefs
-import qualified Utility.RawFilePath as R
import Control.Monad.Free
import Control.Monad.IO.Class
-- Note that while the callback is running, other connections won't be
-- processed, so longterm work should be run in a separate thread by
-- the callback.
-serveUnixSocket :: FilePath -> (Handle -> IO ()) -> IO ()
+serveUnixSocket :: OsPath -> (Handle -> IO ()) -> IO ()
serveUnixSocket unixsocket serveconn = do
- removeWhenExistsWith R.removeLink (toRawFilePath unixsocket)
+ removeWhenExistsWith removeFile unixsocket
soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
- S.bind soc (S.SockAddrUnix unixsocket)
+ S.bind soc (S.SockAddrUnix (fromOsPath unixsocket))
-- Allow everyone to read and write to the socket,
-- so a daemon like tor, that is probably running as a different
-- de sock $ addModes
-- Connections have to authenticate to do anything,
-- so it's fine that other local users can connect to the
-- socket.
- modifyFileMode (toRawFilePath unixsocket) $ addModes
+ modifyFileMode unixsocket $ addModes
[groupReadMode, groupWriteMode, otherReadMode, otherWriteMode]
S.listen soc 2
forever $ do
serviceproc repo = gitCreateProcess
[ Param cmd
- , File (fromRawFilePath (repoPath repo))
+ , File (fromOsPath (repoPath repo))
] repo
serviceproc' repo = (serviceproc repo)
{ std_out = CreatePipe
{-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module P2P.Protocol where
import Utility.Applicative
import Utility.PartialPrelude
import Utility.Metered
-import Utility.FileSystemEncoding
import Utility.MonotonicClock
+import Utility.OsPath
+import qualified Utility.OsString as OS
import Git.FilePath
import Annex.ChangedRefs (ChangedRefs)
import Types.NumCopies
import Control.Monad.Catch
import System.Exit (ExitCode(..))
import System.IO
-import qualified System.FilePath.ByteString as P
-import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Set as S
import Data.Char
instance Proto.Serializable ProtoAssociatedFile where
serialize (ProtoAssociatedFile (AssociatedFile Nothing)) = ""
serialize (ProtoAssociatedFile (AssociatedFile (Just af))) =
- decodeBS $ toInternalGitPath $ encodeBS $ concatMap esc $ fromRawFilePath af
+ fromOsPath $ toInternalGitPath $
+ OS.concat $ map esc $ OS.unpack af
where
- esc '%' = "%%"
- esc c
- | isSpace c = "%"
- | otherwise = [c]
+ esc c = case OS.toChar c of
+ '%' -> literalOsPath "%%"
+ c' | isSpace c' -> literalOsPath "%"
+ _ -> OS.singleton c
- deserialize s = case fromInternalGitPath $ toRawFilePath $ deesc [] s of
+ deserialize s = case fromInternalGitPath $ toOsPath $ deesc [] s of
f
- | B.null f -> Just $ ProtoAssociatedFile $ AssociatedFile Nothing
- | P.isRelative f -> Just $ ProtoAssociatedFile $
+ | OS.null f -> Just $ ProtoAssociatedFile $
+ AssociatedFile Nothing
+ | isRelative f -> Just $ ProtoAssociatedFile $
AssociatedFile $ Just f
| otherwise -> Nothing
where
= TmpContentSize Key (Len -> c)
-- ^ Gets size of the temp file where received content may have
-- been stored. If not present, returns 0.
- | FileSize FilePath (Len -> c)
+ | FileSize OsPath (Len -> c)
-- ^ Gets size of the content of a file. If not present, returns 0.
| ContentSize Key (Maybe Len -> c)
-- ^ Gets size of the content of a key, when the full content is
-- present.
- | ReadContent Key AssociatedFile (Maybe FilePath) Offset (L.ByteString -> Proto Validity -> Proto (Maybe [UUID])) (Maybe [UUID] -> c)
+ | ReadContent Key AssociatedFile (Maybe OsPath) Offset (L.ByteString -> Proto Validity -> Proto (Maybe [UUID])) (Maybe [UUID] -> c)
-- ^ Reads the content of a key and sends it to the callback.
-- Must run the callback, or terminate the protocol connection.
--
-- Note: The ByteString may not contain the entire remaining content
-- of the key. Only once the temp file size == Len has the whole
-- content been transferred.
- | StoreContentTo FilePath (Maybe IncrementalVerifier) Offset Len (Proto L.ByteString) (Proto (Maybe Validity)) ((Bool, Verification) -> c)
+ | StoreContentTo OsPath (Maybe IncrementalVerifier) Offset Len (Proto L.ByteString) (Proto (Maybe Validity)) ((Bool, Verification) -> c)
-- ^ Like StoreContent, but stores the content to a temp file.
| SendContentWith (L.ByteString -> Annex (Maybe Validity -> Annex Bool)) (Proto L.ByteString) (Proto (Maybe Validity)) (Bool -> c)
-- ^ Reads content from the Proto L.ByteString and sends it to the
REMOVE_BEFORE remoteendtime key
checkSuccessFailurePlus
-get :: FilePath -> Key -> Maybe IncrementalVerifier -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification)
+get :: OsPath -> Key -> Maybe IncrementalVerifier -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification)
get dest key iv af m p =
receiveContent (Just m) p sizer storer noothermessages $ \offset ->
GET offset (ProtoAssociatedFile af) key
(ServeReadOnly, UploadPack) -> a Nothing
(ServeReadOnly, ReceivePack) -> a (Just sendReadOnlyError)
-sendContent :: Key -> AssociatedFile -> Maybe FilePath -> Offset -> MeterUpdate -> Proto (Maybe [UUID])
+sendContent :: Key -> AssociatedFile -> Maybe OsPath -> Offset -> MeterUpdate -> Proto (Maybe [UUID])
sendContent key af o offset@(Offset n) p = go =<< local (contentSize key)
where
go (Just (Len totallen)) = do
import Types.ProposedAccepted
import Annex.SpecialRemote.Config
import Annex.Verify
+import qualified Utility.OsString as OS
import qualified Data.Map as M
import qualified System.FilePath.Posix as Posix
deriving (Show, Eq)
-- | A location on an Android device.
-newtype AndroidPath = AndroidPath { fromAndroidPath :: FilePath }
+newtype AndroidPath = AndroidPath { fromAndroidPath :: Posix.FilePath }
remote :: RemoteType
remote = specialRemoteType $ RemoteType
in unlessM (store' serial dest src) $
giveup "adb failed"
-store' :: AndroidSerial -> AndroidPath -> FilePath -> Annex Bool
+store' :: AndroidSerial -> AndroidPath -> OsPath -> Annex Bool
store' serial dest src = checkAdbInPath False $ do
- let destdir = takeDirectory $ fromAndroidPath dest
+ let destdir = Posix.takeDirectory $ fromAndroidPath dest
void $ adbShell serial [Param "mkdir", Param "-p", File destdir]
showOutput -- make way for adb push output
liftIO $ boolSystem "adb" $ mkAdbCommand serial
- [Param "push", File src, File (fromAndroidPath dest)]
+ [Param "push", File (fromOsPath src), File (fromAndroidPath dest)]
retrieve :: AndroidSerial -> AndroidPath -> Retriever
retrieve serial adir = fileRetriever $ \dest k _p ->
let src = androidLocation adir k
- in retrieve' serial src (fromRawFilePath dest)
+ in retrieve' serial src dest
-retrieve' :: AndroidSerial -> AndroidPath -> FilePath -> Annex ()
+retrieve' :: AndroidSerial -> AndroidPath -> OsPath -> Annex ()
retrieve' serial src dest =
unlessM go $
giveup "adb pull failed"
[ Param "pull"
, Param "-a"
, File $ fromAndroidPath src
- , File dest
+ , File $ fromOsPath dest
]
remove :: AndroidSerial -> AndroidPath -> Remover
androidHashDir :: AndroidPath -> Key -> AndroidPath
androidHashDir adir k = AndroidPath $
- fromAndroidPath adir ++ "/" ++ hdir
+ fromAndroidPath adir ++ "/" ++ fromOsPath hdir
where
- hdir = replace [pathSeparator] "/" (fromRawFilePath (hashDirLower def k))
+ hdir = OS.intercalate (literalOsPath "/") $ OS.split pathSeparator $
+ hashDirLower def k
-storeExportM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
+storeExportM :: AndroidSerial -> AndroidPath -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
storeExportM serial adir src _k loc _p =
unlessM (store' serial dest src) $
giveup "adb failed"
where
dest = androidExportLocation adir loc
-retrieveExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification
+retrieveExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification
retrieveExportM serial adir k loc dest _p =
verifyKeyContentIncrementally AlwaysVerify k $ \iv ->
- tailVerify iv (toRawFilePath dest) $
+ tailVerify iv dest $
retrieve' serial src dest
where
src = androidExportLocation adir loc
let (stat, fn) = separate (== '\t') l
sz = fromMaybe 0 (readish (takeWhile (/= ' ') stat))
cid = ContentIdentifier (encodeBS stat)
- loc = mkImportLocation $ toRawFilePath $
+ loc = mkImportLocation $ toOsPath $
Posix.makeRelative (fromAndroidPath adir) fn
in Just (loc, (cid, sz))
mk _ = Nothing
-- connection is reasonably fast, it's probably as good as
-- git's handling of similar situations with files being modified while
-- it's updating the working tree for a merge.
-retrieveExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> ExportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)
+retrieveExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> ExportLocation -> [ContentIdentifier] -> OsPath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)
retrieveExportWithContentIdentifierM serial adir loc cids dest gk _p = do
case gk of
Right mkkey -> do
return (k, UnVerified)
Left k -> do
v <- verifyKeyContentIncrementally DefaultVerify k
- (\iv -> tailVerify iv (toRawFilePath dest) go)
+ (\iv -> tailVerify iv dest go)
return (k, v)
where
go = do
_ -> giveup "the file on the android device has changed"
src = androidExportLocation adir loc
-storeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
+storeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
storeExportWithContentIdentifierM serial adir src _k loc overwritablecids _p =
ifM checkcanoverwrite
( ifM (store' serial dest src)
androidExportLocation :: AndroidPath -> ExportLocation -> AndroidPath
androidExportLocation adir loc = AndroidPath $
- fromAndroidPath adir ++ "/" ++ fromRawFilePath (fromExportLocation loc)
+ fromAndroidPath adir ++ "/" ++ fromOsPath (fromExportLocation loc)
-- | List all connected Android devices.
enumerateAdbConnected :: Annex [AndroidSerial]
import qualified Annex.Url as Url
import Remote.Helper.ExportImport
import Annex.SpecialRemote.Config
-import qualified Utility.RawFilePath as R
+import qualified Utility.OsString as OS
import Network.URI
-import qualified System.FilePath.ByteString as P
-import qualified Data.ByteString as S
-
#ifdef WITH_TORRENTPARSER
import Data.Torrent
import qualified Utility.FileIO as F
, remoteStateHandle = rs
}
-downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+downloadKey :: Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
downloadKey key _file dest p _ = do
get . map (torrentUrlNum . fst . getDownloader) =<< getBitTorrentUrls key
-- While bittorrent verifies the hash in the torrent file,
unless ok $
get []
-uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
+uploadKey :: Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()
uploadKey _ _ _ _ = giveup "upload to bittorrent not supported"
dropKey :: Maybe SafeDropProof -> Key -> Annex ()
torrentUrlKey u = return $ fromUrl (fst $ torrentUrlNum u) Nothing False
{- Temporary filename to use to store the torrent file. -}
-tmpTorrentFile :: URLString -> Annex RawFilePath
+tmpTorrentFile :: URLString -> Annex OsPath
tmpTorrentFile u = fromRepo . gitAnnexTmpObjectLocation =<< torrentUrlKey u
{- A cleanup action is registered to delete the torrent file
-}
registerTorrentCleanup :: URLString -> Annex ()
registerTorrentCleanup u = Annex.addCleanupAction (TorrentCleanup u) $
- liftIO . removeWhenExistsWith R.removeLink =<< tmpTorrentFile u
+ liftIO . removeWhenExistsWith removeFile =<< tmpTorrentFile u
{- Downloads the torrent file. (Not its contents.) -}
downloadTorrentFile :: URLString -> Annex Bool
downloadTorrentFile u = do
torrent <- tmpTorrentFile u
- ifM (liftIO $ doesFileExist (fromRawFilePath torrent))
+ ifM (liftIO $ doesFileExist torrent)
( return True
, do
showAction "downloading torrent file"
if isTorrentMagnetUrl u
then withOtherTmp $ \othertmp -> do
kf <- keyFile <$> torrentUrlKey u
- let metadir = othertmp P.</> "torrentmeta" P.</> kf
+ let metadir = othertmp </> literalOsPath "torrentmeta" </> kf
createAnnexDirectory metadir
showOutput
ok <- downloadMagnetLink u metadir torrent
- liftIO $ removeDirectoryRecursive
- (fromRawFilePath metadir)
+ liftIO $ removeDirectoryRecursive metadir
return ok
else withOtherTmp $ \othertmp -> do
- withTmpFileIn (toOsPath othertmp) (toOsPath "torrent") $ \f h -> do
+ withTmpFileIn othertmp (literalOsPath "torrent") $ \f h -> do
liftIO $ hClose h
- resetAnnexFilePerm (fromOsPath f)
+ resetAnnexFilePerm f
ok <- Url.withUrlOptions $
- Url.download nullMeterUpdate Nothing u (fromRawFilePath (fromOsPath f))
+ Url.download nullMeterUpdate Nothing u f
when ok $
- liftIO $ moveFile (fromOsPath f) torrent
+ liftIO $ moveFile f torrent
return ok
)
-downloadMagnetLink :: URLString -> RawFilePath -> RawFilePath -> Annex Bool
+downloadMagnetLink :: URLString -> OsPath -> OsPath -> Annex Bool
downloadMagnetLink u metadir dest = ifM download
( liftIO $ do
- ts <- filter (".torrent" `S.isSuffixOf`)
+ ts <- filter (literalOsPath ".torrent" `OS.isSuffixOf`)
<$> dirContents metadir
case ts of
(t:[]) -> do
, Param "--seed-time=0"
, Param "--summary-interval=0"
, Param "-d"
- , File (fromRawFilePath metadir)
+ , File (fromOsPath metadir)
]
-downloadTorrentContent :: Key -> URLString -> FilePath -> Int -> MeterUpdate -> Annex Bool
+downloadTorrentContent :: Key -> URLString -> OsPath -> Int -> MeterUpdate -> Annex Bool
downloadTorrentContent k u dest filenum p = do
torrent <- tmpTorrentFile u
withOtherTmp $ \othertmp -> do
kf <- keyFile <$> torrentUrlKey u
- let downloaddir = othertmp P.</> "torrent" P.</> kf
+ let downloaddir = othertmp </> literalOsPath "torrent" </> kf
createAnnexDirectory downloaddir
f <- wantedfile torrent
- let dlf = fromRawFilePath downloaddir </> f
+ let dlf = downloaddir </> f
showOutput
ifM (download torrent downloaddir <&&> liftIO (doesFileExist dlf))
( do
- liftIO $ moveFile (toRawFilePath dlf) (toRawFilePath dest)
+ liftIO $ moveFile dlf dest
-- The downloaddir is not removed here,
-- so if aria downloaded parts of other
-- files, and this is called again, it will
where
download torrent tmpdir = ariaProgress (fromKey keySize k) p
[ Param $ "--select-file=" ++ show filenum
- , File (fromRawFilePath torrent)
+ , File (fromOsPath torrent)
, Param "-d"
- , File (fromRawFilePath tmpdir)
+ , File (fromOsPath tmpdir)
, Param "--seed-time=0"
, Param "--summary-interval=0"
, Param "--file-allocation=none"
{- Examines the torrent file and gets the list of files in it,
- and their sizes.
-}
-torrentFileSizes :: RawFilePath -> IO [(FilePath, Integer)]
+torrentFileSizes :: OsPath -> IO [(OsPath, Integer)]
torrentFileSizes torrent = do
#ifdef WITH_TORRENTPARSER
- let mkfile = joinPath . map (scrub . decodeBL)
- b <- F.readFile (toOsPath torrent)
+ let mkfile = joinPath . map (scrub . toOsPath)
+ b <- F.readFile torrent
return $ case readTorrent b of
Left e -> giveup $ "failed to parse torrent: " ++ e
Right t -> case tInfo t of
fnl <- getfield "file name"
szl <- map readish <$> getfield "file size"
case (fnl, szl) of
- ((fn:[]), (Just sz:[])) -> return [(scrub fn, sz)]
+ ((fn:[]), (Just sz:[])) -> return [(scrub (toOsPath fn), sz)]
_ -> parsefailed (show (fnl, szl))
else do
v <- getfield "directory name"
case v of
- (d:[]) -> return $ map (splitsize d) files
+ (d:[]) -> return $ map (splitsize (toOsPath d)) files
_ -> parsefailed (show v)
where
- getfield = btshowmetainfo (fromRawFilePath torrent)
+ getfield = btshowmetainfo (fromOsPath torrent)
parsefailed s = giveup $ "failed to parse btshowmetainfo output for torrent file: " ++ show s
-- btshowmetainfo outputs a list of "filename (size)"
- splitsize d l = (scrub (d </> fn), sz)
+ splitsize d l = (scrub (d </> toOsPath fn), sz)
where
sz = fromMaybe (parsefailed l) $ readish $
reverse $ takeWhile (/= '(') $ dropWhile (== ')') $
dropWhile (/= '(') $ dropWhile (== ')') $ reverse l
#endif
-- a malicious torrent file might try to do directory traversal
- scrub f = if isAbsolute f || any (== "..") (splitPath f)
+ scrub f = if isAbsolute f || any (== literalOsPath "..") (splitPath f)
then giveup "found unsafe filename in torrent!"
else f
import qualified Data.Map as M
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
-import qualified System.FilePath.ByteString as P
newtype BorgRepo = BorgRepo { locBorgRepo :: String }
absBorgRepo :: BorgRepo -> IO BorgRepo
absBorgRepo r@(BorgRepo p)
- | borgLocal r = BorgRepo . fromRawFilePath
- <$> absPath (toRawFilePath p)
+ | borgLocal r = BorgRepo . fromOsPath <$> absPath (toOsPath p)
| otherwise = return r
-borgRepoLocalPath :: BorgRepo -> Maybe FilePath
+borgRepoLocalPath :: BorgRepo -> Maybe OsPath
borgRepoLocalPath r@(BorgRepo p)
- | borgLocal r = Just p
+ | borgLocal r = Just (toOsPath p)
| otherwise = Nothing
checkAvailability :: BorgRepo -> Annex Availability
checkAvailability borgrepo@(BorgRepo r) =
- checkPathAvailability (borgLocal borgrepo) r
+ checkPathAvailability (borgLocal borgrepo) (toOsPath r)
listImportableContentsM :: UUID -> BorgRepo -> ParsedRemoteConfig -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)))
listImportableContentsM u borgrepo c = prompt $ do
parsefilelist archivename (bsz:f:extra:rest) = case readMaybe (fromRawFilePath bsz) of
Nothing -> parsefilelist archivename rest
Just sz ->
- let loc = genImportLocation f
+ let loc = genImportLocation (toOsPath f)
-- borg list reports hard links as 0 byte files,
-- with the extra field set to " link to ".
-- When the annex object is a hard link to
borgContentIdentifier :: ContentIdentifier
borgContentIdentifier = ContentIdentifier mempty
--- Convert a path file a borg archive to a path that can be used as an
+-- Convert a path from a borg archive to a path that can be used as an
-- ImportLocation. The archive name gets used as a subdirectory,
-- which this path is inside.
--
--
-- This scheme also relies on the fact that paths in a borg archive are
-- always relative, not absolute.
-genImportLocation :: RawFilePath -> RawFilePath
+genImportLocation :: OsPath -> OsPath
genImportLocation = fromImportLocation . ThirdPartyPopulated.mkThirdPartyImportLocation
genImportChunkSubDir :: BorgArchiveName -> ImportChunkSubDir
-genImportChunkSubDir = ImportChunkSubDir . fromImportLocation . ThirdPartyPopulated.mkThirdPartyImportLocation
+genImportChunkSubDir = ImportChunkSubDir . fromImportLocation
+ . ThirdPartyPopulated.mkThirdPartyImportLocation . toOsPath
-extractImportLocation :: ImportLocation -> (BorgArchiveName, RawFilePath)
-extractImportLocation loc = go $ P.splitDirectories $
+extractImportLocation :: ImportLocation -> (BorgArchiveName, OsPath)
+extractImportLocation loc = go $ splitDirectories $
ThirdPartyPopulated.fromThirdPartyImportLocation loc
where
- go (archivename:rest) = (archivename, P.joinPath rest)
- go _ = giveup $ "Unable to parse import location " ++ fromRawFilePath (fromImportLocation loc)
+ go (archivename:rest) = (fromOsPath archivename, joinPath rest)
+ go _ = giveup $ "Unable to parse import location " ++ fromOsPath (fromImportLocation loc)
-- Since the ImportLocation starts with the archive name, a list of all
-- archive names we've already imported can be found by just listing the
-- last imported tree. And the contents of those archives can be retrieved
-- by listing the subtree recursively, which will likely be quite a lot
-- faster than running borg.
-getImported :: UUID -> Annex (M.Map BorgArchiveName (Annex [(RawFilePath, (ContentIdentifier, ByteSize))]))
+getImported :: UUID -> Annex (M.Map BorgArchiveName (Annex [(OsPath, (ContentIdentifier, ByteSize))]))
getImported u = M.unions <$> (mapM go . exportedTreeishes =<< getExport u)
where
go t = M.fromList . mapMaybe mk
mk ti
| toTreeItemType (LsTree.mode ti) == Just TreeSubtree = Just
- ( getTopFilePath (LsTree.file ti)
+ ( fromOsPath (getTopFilePath (LsTree.file ti))
, getcontents (LsTree.sha ti)
)
| otherwise = Nothing
mkcontents ti = do
let f = ThirdPartyPopulated.fromThirdPartyImportLocation $
mkImportLocation $ getTopFilePath $ LsTree.file ti
- k <- fileKey (P.takeFileName f)
+ k <- fileKey (takeFileName f)
return
( genImportLocation f
,
, Param "--format"
, Param "1"
, Param (borgArchive borgrepo archivename)
- , File (fromRawFilePath archivefile)
+ , File (fromOsPath archivefile)
]
-- borg list exits nonzero with an error message if an archive
-- no longer exists. But, the user can delete archives at any
, giveup $ "Unable to access borg repository " ++ locBorgRepo borgrepo
)
-retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)
+retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> [ContentIdentifier] -> OsPath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)
retrieveExportWithContentIdentifierM borgrepo loc _ dest gk _ = do
showOutput
case gk of
return (k, UnVerified)
Left k -> do
v <- verifyKeyContentIncrementally DefaultVerify k
- (\iv -> tailVerify iv (toRawFilePath dest) go)
+ (\iv -> tailVerify iv dest go)
return (k, v)
where
go = prompt $ withOtherTmp $ \othertmp -> liftIO $ do
, Param "--noacls"
, Param "--nobsdflags"
, Param (borgArchive absborgrepo archivename)
- , File (fromRawFilePath archivefile)
+ , File (fromOsPath archivefile)
]
(Nothing, Nothing, Nothing, pid) <- createProcess $ p
- { cwd = Just (fromRawFilePath othertmp) }
+ { cwd = Just (fromOsPath othertmp) }
forceSuccessProcess p pid
-- Filepaths in borg archives are relative, so it's ok to
-- combine with </>
- moveFile (othertmp P.</> archivefile) (toRawFilePath dest)
- removeDirectoryRecursive (fromRawFilePath othertmp)
+ moveFile (othertmp </> archivefile) dest
+ removeDirectoryRecursive othertmp
(archivename, archivefile) = extractImportLocation loc
import qualified Data.Map as M
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
-import qualified System.FilePath.ByteString as P
import Data.ByteString.Lazy.UTF8 (fromString)
import Control.Concurrent.Async
, getRepo = return r
, gitconfig = gc
, localpath = if bupLocal buprepo && not (null buprepo)
- then Just buprepo
+ then Just (toOsPath buprepo)
else Nothing
, remotetype = remote
, availability = if null buprepo
then pure LocallyAvailable
- else checkPathAvailability (bupLocal buprepo) buprepo
+ else checkPathAvailability (bupLocal buprepo) (toOsPath buprepo)
, readonly = False
, appendonly = False
, untrustworthy = False
(sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r c remotecmd
liftIO $ runner sshcmd sshparams
where
- path = fromRawFilePath $ Git.repoPath r
+ path = fromOsPath $ Git.repoPath r
base = fromMaybe path (stripPrefix "/~/" path)
dir = shellEscape base
bup2GitRemote "" = do
-- bup -r "" operates on ~/.bup
h <- myHomeDir
- Git.Construct.fromPath $ toRawFilePath $ h </> ".bup"
+ Git.Construct.fromPath $ toOsPath h </> literalOsPath ".bup"
bup2GitRemote r
| bupLocal r =
if "/" `isPrefixOf` r
- then Git.Construct.fromPath (toRawFilePath r)
+ then Git.Construct.fromPath (toOsPath r)
else giveup "please specify an absolute path"
| otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir
where
lockBup :: Bool -> Remote -> Annex a -> Annex a
lockBup writer r a = do
dir <- fromRepo gitAnnexRemotesDir
- unlessM (liftIO $ doesDirectoryExist (fromRawFilePath dir)) $
+ unlessM (liftIO $ doesDirectoryExist dir) $
createAnnexDirectory dir
let remoteid = fromUUID (uuid r)
- let lck = dir P.</> remoteid <> ".lck"
+ let lck = dir </> remoteid <> literalOsPath ".lck"
if writer
then withExclusiveLock lck a
else withSharedLock lck a
, getRepo = return r
, gitconfig = gc
, localpath = if ddarLocal ddarrepo && not (null $ ddarRepoLocation ddarrepo)
- then Just $ ddarRepoLocation ddarrepo
+ then Just $ toOsPath $ ddarRepoLocation ddarrepo
else Nothing
, remotetype = remote
, availability = checkPathAvailability
(ddarLocal ddarrepo && not (null $ ddarRepoLocation ddarrepo))
- (ddarRepoLocation ddarrepo)
+ (toOsPath (ddarRepoLocation ddarrepo))
, readonly = False
, appendonly = False
, untrustworthy = False
, Param "-N"
, Param $ serializeKey k
, Param $ ddarRepoLocation ddarrepo
- , File src
+ , File $ fromOsPath src
]
unlessM (liftIO $ boolSystem "ddar" params) $
giveup "ddar failed"
import qualified Data.Map as M
import qualified Data.List.NonEmpty as NE
-import qualified System.FilePath.ByteString as P
import Data.Default
import System.PosixCompat.Files (isRegularFile, deviceID)
#ifndef mingw32_HOST_OS
, config = c
, getRepo = return r
, gitconfig = gc
- , localpath = Just dir'
+ , localpath = Just dir
, readonly = False
, appendonly = False
, untrustworthy = False
- , availability = checkPathAvailability True dir'
+ , availability = checkPathAvailability True dir
, remotetype = remote
, mkUnavailable = gen r u rc
(gc { remoteAnnexDirectory = Just "/dev/null" }) rs
, remoteStateHandle = rs
}
where
- dir = toRawFilePath dir'
- dir' = fromMaybe (giveup "missing directory") (remoteAnnexDirectory gc)
+ dir = toOsPath dir'
+ dir' = fromMaybe (giveup "missing directory")
+ (remoteAnnexDirectory gc)
directorySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
directorySetup _ mu _ c gc = do
-- verify configuration is sane
let dir = maybe (giveup "Specify directory=") fromProposedAccepted $
M.lookup directoryField c
- absdir <- liftIO $ fromRawFilePath <$> absPath (toRawFilePath dir)
+ absdir <- liftIO $ absPath (toOsPath dir)
liftIO $ unlessM (doesDirectoryExist absdir) $
- giveup $ "Directory does not exist: " ++ absdir
+ giveup $ "Directory does not exist: " ++ fromOsPath absdir
(c', _encsetup) <- encryptionSetup c gc
-- The directory is stored in git config, not in this remote's
-- persistent state, so it can vary between hosts.
- gitConfigSpecialRemote u c' [("directory", absdir)]
+ gitConfigSpecialRemote u c' [("directory", fromOsPath absdir)]
return (M.delete directoryField c', u)
{- Locations to try to access a given Key in the directory.
- We try more than one since we used to write to different hash
- directories. -}
-locations :: RawFilePath -> Key -> NE.NonEmpty RawFilePath
-locations d k = NE.map (d P.</>) (keyPaths k)
+locations :: OsPath -> Key -> NE.NonEmpty OsPath
+locations d k = NE.map (d </>) (keyPaths k)
-locations' :: RawFilePath -> Key -> [RawFilePath]
+locations' :: OsPath -> Key -> [OsPath]
locations' d k = NE.toList (locations d k)
{- Returns the location of a Key in the directory. If the key is
- present, returns the location that is actually used, otherwise
- returns the first, default location. -}
-getLocation :: RawFilePath -> Key -> IO RawFilePath
+getLocation :: OsPath -> Key -> IO OsPath
getLocation d k = do
let locs = locations d k
- fromMaybe (NE.head locs)
- <$> firstM (doesFileExist . fromRawFilePath)
- (NE.toList locs)
+ fromMaybe (NE.head locs) <$> firstM doesFileExist (NE.toList locs)
{- Directory where the file(s) for a key are stored. -}
-storeDir :: RawFilePath -> Key -> RawFilePath
-storeDir d k = P.addTrailingPathSeparator $
- d P.</> hashDirLower def k P.</> keyFile k
+storeDir :: OsPath -> Key -> OsPath
+storeDir d k = addTrailingPathSeparator $
+ d </> hashDirLower def k </> keyFile k
{- Check if there is enough free disk space in the remote's directory to
- store the key. Note that the unencrypted key size is checked. -}
-storeKeyM :: RawFilePath -> ChunkConfig -> CopyCoWTried -> Storer
+storeKeyM :: OsPath -> ChunkConfig -> CopyCoWTried -> Storer
storeKeyM d chunkconfig cow k c m =
ifM (checkDiskSpaceDirectory d k)
( do
store = case chunkconfig of
LegacyChunks chunksize ->
let go _k b p = liftIO $ Legacy.store
- (fromRawFilePath d)
+ (fromOsPath d)
chunksize
(finalizeStoreGeneric d)
k b p
- (fromRawFilePath tmpdir)
- (fromRawFilePath destdir)
+ (fromOsPath tmpdir)
+ (fromOsPath destdir)
in byteStorer go k c m
NoChunks ->
let go _k src p = liftIO $ do
- void $ fileCopier cow src tmpf p Nothing
+ void $ fileCopier cow (fromOsPath src) (fromOsPath tmpf) p Nothing
finalizeStoreGeneric d tmpdir destdir
in fileStorer go k c m
_ ->
finalizeStoreGeneric d tmpdir destdir
in byteStorer go k c m
- tmpdir = P.addTrailingPathSeparator $ d P.</> "tmp" P.</> kf
- tmpf = fromRawFilePath tmpdir </> fromRawFilePath kf
+ tmpdir = addTrailingPathSeparator $ d </> literalOsPath "tmp" </> kf
+ tmpf = tmpdir </> kf
kf = keyFile k
destdir = storeDir d k
-checkDiskSpaceDirectory :: RawFilePath -> Key -> Annex Bool
+checkDiskSpaceDirectory :: OsPath -> Key -> Annex Bool
checkDiskSpaceDirectory d k = do
annexdir <- fromRepo gitAnnexObjectDir
samefilesystem <- liftIO $ catchDefaultIO False $
(\a b -> deviceID a == deviceID b)
- <$> R.getSymbolicLinkStatus d
- <*> R.getSymbolicLinkStatus annexdir
+ <$> R.getSymbolicLinkStatus (fromOsPath d)
+ <*> R.getSymbolicLinkStatus (fromOsPath annexdir)
checkDiskSpace Nothing (Just d) k 0 samefilesystem
{- Passed a temp directory that contains the files that should be placed
- in the dest directory, moves it into place. Anything already existing
- in the dest directory will be deleted. File permissions will be locked
- down. -}
-finalizeStoreGeneric :: RawFilePath -> RawFilePath -> RawFilePath -> IO ()
+finalizeStoreGeneric :: OsPath -> OsPath -> OsPath -> IO ()
finalizeStoreGeneric d tmp dest = do
- removeDirGeneric False (fromRawFilePath d) dest'
+ removeDirGeneric False d dest
createDirectoryUnder [d] (parentDir dest)
- renameDirectory (fromRawFilePath tmp) dest'
+ renameDirectory tmp dest
-- may fail on some filesystems
void $ tryIO $ do
mapM_ preventWrite =<< dirContents dest
preventWrite dest
- where
- dest' = fromRawFilePath dest
-retrieveKeyFileM :: RawFilePath -> ChunkConfig -> CopyCoWTried -> Retriever
+retrieveKeyFileM :: OsPath -> ChunkConfig -> CopyCoWTried -> Retriever
retrieveKeyFileM d (LegacyChunks _) _ = Legacy.retrieve locations' d
retrieveKeyFileM d NoChunks cow = fileRetriever' $ \dest k p iv -> do
- src <- liftIO $ fromRawFilePath <$> getLocation d k
- void $ liftIO $ fileCopier cow src (fromRawFilePath dest) p iv
+ src <- liftIO $ getLocation d k
+ void $ liftIO $ fileCopier cow (fromOsPath src) (fromOsPath dest) p iv
retrieveKeyFileM d _ _ = byteRetriever $ \k sink ->
- sink =<< liftIO (F.readFile . toOsPath =<< getLocation d k)
+ sink =<< liftIO (F.readFile =<< getLocation d k)
-retrieveKeyFileCheapM :: RawFilePath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ())
+retrieveKeyFileCheapM :: OsPath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> OsPath -> Annex ())
-- no cheap retrieval possible for chunks
retrieveKeyFileCheapM _ (UnpaddedChunks _) = Nothing
retrieveKeyFileCheapM _ (LegacyChunks _) = Nothing
#ifndef mingw32_HOST_OS
retrieveKeyFileCheapM d NoChunks = Just $ \k _af f -> liftIO $ do
- file <- fromRawFilePath <$> (absPath =<< getLocation d k)
+ file <- absPath =<< getLocation d k
ifM (doesFileExist file)
- ( R.createSymbolicLink (toRawFilePath file) (toRawFilePath f)
+ ( R.createSymbolicLink (fromOsPath file) (fromOsPath f)
, giveup "content file not present in remote"
)
#else
retrieveKeyFileCheapM _ _ = Nothing
#endif
-removeKeyM :: RawFilePath -> Remover
-removeKeyM d _proof k = liftIO $ removeDirGeneric True
- (fromRawFilePath d)
- (fromRawFilePath (storeDir d k))
+removeKeyM :: OsPath -> Remover
+removeKeyM d _proof k = liftIO $ removeDirGeneric True d (storeDir d k)
{- Removes the directory, which must be located under the topdir.
-
- can also be removed. Failure to remove such a directory is not treated
- as an error.
-}
-removeDirGeneric :: Bool -> FilePath -> FilePath -> IO ()
+removeDirGeneric :: Bool -> OsPath -> OsPath -> IO ()
removeDirGeneric removeemptyparents topdir dir = do
- void $ tryIO $ allowWrite (toRawFilePath dir)
+ void $ tryIO $ allowWrite dir
#ifdef mingw32_HOST_OS
{- Windows needs the files inside the directory to be writable
- before it can delete them. -}
- void $ tryIO $ mapM_ (allowWrite . toRawFilePath) =<< dirContents dir
+ void $ tryIO $ mapM_ allowWrite =<< dirContents dir
#endif
tryNonAsync (removeDirectoryRecursive dir) >>= \case
Right () -> return ()
unlessM (doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)) $
throwM e
when removeemptyparents $ do
- subdir <- relPathDirToFile (toRawFilePath topdir) (P.takeDirectory (toRawFilePath dir))
- goparents (Just (P.takeDirectory subdir)) (Right ())
+ subdir <- relPathDirToFile topdir (takeDirectory dir)
+ goparents (Just (takeDirectory subdir)) (Right ())
where
goparents _ (Left _e) = return ()
goparents Nothing _ = return ()
goparents (Just subdir) _ = do
- let d = topdir </> fromRawFilePath subdir
+ let d = topdir </> subdir
goparents (upFrom subdir) =<< tryIO (removeDirectory d)
-checkPresentM :: RawFilePath -> ChunkConfig -> CheckPresent
+checkPresentM :: OsPath -> ChunkConfig -> CheckPresent
checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations' k
checkPresentM d _ k = checkPresentGeneric d (locations' d k)
-checkPresentGeneric :: RawFilePath -> [RawFilePath] -> Annex Bool
+checkPresentGeneric :: OsPath -> [OsPath] -> Annex Bool
checkPresentGeneric d ps = checkPresentGeneric' d $
- liftIO $ anyM (doesFileExist . fromRawFilePath) ps
+ liftIO $ anyM doesFileExist ps
-checkPresentGeneric' :: RawFilePath -> Annex Bool -> Annex Bool
+checkPresentGeneric' :: OsPath -> Annex Bool -> Annex Bool
checkPresentGeneric' d check = ifM check
( return True
- , ifM (liftIO $ doesDirectoryExist (fromRawFilePath d))
+ , ifM (liftIO $ doesDirectoryExist d)
( return False
- , giveup $ "directory " ++ fromRawFilePath d ++ " is not accessible"
+ , giveup $ "directory " ++ fromOsPath d ++ " is not accessible"
)
)
-storeExportM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
+storeExportM :: OsPath -> CopyCoWTried -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
storeExportM d cow src _k loc p = do
- liftIO $ createDirectoryUnder [d] (P.takeDirectory dest)
+ liftIO $ createDirectoryUnder [d] (takeDirectory dest)
-- Write via temp file so that checkPresentGeneric will not
-- see it until it's fully stored.
- viaTmp go (toOsPath dest) ()
+ viaTmp go dest ()
where
dest = exportPath d loc
- go tmp () = void $ liftIO $ fileCopier cow src (fromRawFilePath (fromOsPath tmp)) p Nothing
+ go tmp () = void $ liftIO $
+ fileCopier cow (fromOsPath src) (fromOsPath tmp) p Nothing
-retrieveExportM :: RawFilePath -> CopyCoWTried -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification
+retrieveExportM :: OsPath -> CopyCoWTried -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification
retrieveExportM d cow k loc dest p =
verifyKeyContentIncrementally AlwaysVerify k $ \iv ->
- void $ liftIO $ fileCopier cow src dest p iv
+ void $ liftIO $ fileCopier cow src (fromOsPath dest) p iv
where
- src = fromRawFilePath $ exportPath d loc
+ src = fromOsPath $ exportPath d loc
-removeExportM :: RawFilePath -> Key -> ExportLocation -> Annex ()
+removeExportM :: OsPath -> Key -> ExportLocation -> Annex ()
removeExportM d _k loc = liftIO $ do
- removeWhenExistsWith R.removeLink src
+ removeWhenExistsWith removeFile src
removeExportLocation d loc
where
src = exportPath d loc
-checkPresentExportM :: RawFilePath -> Key -> ExportLocation -> Annex Bool
+checkPresentExportM :: OsPath -> Key -> ExportLocation -> Annex Bool
checkPresentExportM d _k loc =
checkPresentGeneric d [exportPath d loc]
-renameExportM :: RawFilePath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
+renameExportM :: OsPath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
renameExportM d _k oldloc newloc = liftIO $ do
- createDirectoryUnder [d] (P.takeDirectory dest)
- renameFile (fromRawFilePath src) (fromRawFilePath dest)
+ createDirectoryUnder [d] (takeDirectory dest)
+ renameFile src dest
removeExportLocation d oldloc
return (Just ())
where
src = exportPath d oldloc
dest = exportPath d newloc
-exportPath :: RawFilePath -> ExportLocation -> RawFilePath
-exportPath d loc = d P.</> fromExportLocation loc
+exportPath :: OsPath -> ExportLocation -> OsPath
+exportPath d loc = d </> fromExportLocation loc
{- Removes the ExportLocation's parent directory and its parents, so long as
- they're empty, up to but not including the topdir. -}
-removeExportLocation :: RawFilePath -> ExportLocation -> IO ()
+removeExportLocation :: OsPath -> ExportLocation -> IO ()
removeExportLocation topdir loc =
- go (Just $ P.takeDirectory $ fromExportLocation loc) (Right ())
+ go (Just $ takeDirectory $ fromExportLocation loc) (Right ())
where
go _ (Left _e) = return ()
go Nothing _ = return ()
go (Just loc') _ =
- let p = fromRawFilePath $ exportPath topdir $
- mkExportLocation loc'
+ let p = exportPath topdir $ mkExportLocation loc'
in go (upFrom loc') =<< tryIO (removeDirectory p)
-listImportableContentsM :: IgnoreInodes -> RawFilePath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)))
+listImportableContentsM :: IgnoreInodes -> OsPath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)))
listImportableContentsM ii dir = liftIO $ do
l' <- mapM go =<< dirContentsRecursiveSkipping (const False) False dir
return $ Just $ ImportableContentsComplete $
ImportableContents (catMaybes l') []
where
go f = do
- st <- R.getSymbolicLinkStatus f
+ st <- R.getSymbolicLinkStatus (fromOsPath f)
mkContentIdentifier ii f st >>= \case
Nothing -> return Nothing
Just cid -> do
-- and also normally the inode, unless ignoreinodes=yes.
--
-- If the file is not a regular file, this will return Nothing.
-mkContentIdentifier :: IgnoreInodes -> RawFilePath -> FileStatus -> IO (Maybe ContentIdentifier)
+mkContentIdentifier :: IgnoreInodes -> OsPath -> FileStatus -> IO (Maybe ContentIdentifier)
mkContentIdentifier (IgnoreInodes ii) f st =
liftIO $ fmap (ContentIdentifier . encodeBS . showInodeCache)
<$> if ii
let ic' = replaceInode 0 ic
in ContentIdentifier (encodeBS (showInodeCache ic'))
-importKeyM :: IgnoreInodes -> RawFilePath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key)
+importKeyM :: IgnoreInodes -> OsPath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key)
importKeyM ii dir loc cid sz p = do
backend <- chooseBackend f
unsizedk <- fst <$> genKey ks p backend
let k = alterKey unsizedk $ \kd -> kd
{ keySize = keySize kd <|> Just sz }
currcid <- liftIO $ mkContentIdentifier ii absf
- =<< R.getSymbolicLinkStatus absf
+ =<< R.getSymbolicLinkStatus (fromOsPath absf)
guardSameContentIdentifiers (return (Just k)) [cid] currcid
where
f = fromExportLocation loc
- absf = dir P.</> f
+ absf = dir </> f
ks = KeySource
{ keyFilename = f
, contentLocation = absf
, inodeCache = Nothing
}
-retrieveExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> ExportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)
+retrieveExportWithContentIdentifierM :: IgnoreInodes -> OsPath -> CopyCoWTried -> ExportLocation -> [ContentIdentifier] -> OsPath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)
retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p =
case gk of
Right mkkey -> do
return (k, v)
where
f = exportPath dir loc
- f' = fromRawFilePath f
-
+ f' = fromOsPath f
+
go iv = precheck (docopy iv)
- docopy iv = ifM (liftIO $ tryCopyCoW cow f' dest p)
+ docopy iv = ifM (liftIO $ tryCopyCoW cow (fromOsPath f) (fromOsPath dest) p)
( postcheckcow (liftIO $ maybe noop unableIncrementalVerifier iv)
, docopynoncow iv
)
#ifndef mingw32_HOST_OS
let open = do
-- Need a duplicate fd for the post check.
- fd <- openFdWithMode f ReadOnly Nothing defaultFileFlags
+ fd <- openFdWithMode f' ReadOnly Nothing defaultFileFlags
dupfd <- dup fd
h <- fdToHandle fd
return (h, dupfd)
let close = hClose
bracketIO open close $ \h -> do
#endif
- liftIO $ fileContentCopier h dest p iv
+ liftIO $ fileContentCopier h (fromOsPath dest) p iv
#ifndef mingw32_HOST_OS
postchecknoncow dupfd (return ())
#else
-- content.
precheck cont = guardSameContentIdentifiers cont cids
=<< liftIO . mkContentIdentifier ii f
- =<< liftIO (R.getSymbolicLinkStatus f)
+ =<< liftIO (R.getSymbolicLinkStatus f')
-- Check after copy, in case the file was changed while it was
-- being copied.
#ifndef mingw32_HOST_OS
=<< getFdStatus fd
#else
- =<< R.getSymbolicLinkStatus f
+ =<< R.getSymbolicLinkStatus f'
#endif
guardSameContentIdentifiers cont cids currcid
-- restored to the original content before this check.
postcheckcow cont = do
currcid <- liftIO $ mkContentIdentifier ii f
- =<< R.getSymbolicLinkStatus f
+ =<< R.getSymbolicLinkStatus f'
guardSameContentIdentifiers cont cids currcid
-storeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
+storeExportWithContentIdentifierM :: IgnoreInodes -> OsPath -> CopyCoWTried -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do
liftIO $ createDirectoryUnder [dir] destdir
- withTmpFileIn (toOsPath destdir) template $ \tmpf tmph -> do
+ withTmpFileIn destdir template $ \tmpf tmph -> do
let tmpf' = fromOsPath tmpf
liftIO $ hClose tmph
- void $ liftIO $ fileCopier cow src (fromRawFilePath tmpf') p Nothing
- resetAnnexFilePerm tmpf'
- liftIO (R.getSymbolicLinkStatus tmpf') >>= liftIO . mkContentIdentifier ii tmpf' >>= \case
+ void $ liftIO $ fileCopier cow (fromOsPath src) (fromOsPath tmpf) p Nothing
+ resetAnnexFilePerm tmpf
+ liftIO (R.getSymbolicLinkStatus tmpf') >>= liftIO . mkContentIdentifier ii tmpf >>= \case
Nothing -> giveup "unable to generate content identifier"
Just newcid -> do
checkExportContent ii dir loc
overwritablecids
(giveup "unsafe to overwrite file")
- (const $ liftIO $ R.rename tmpf' dest)
+ (const $ liftIO $ R.rename tmpf' (fromOsPath dest))
return newcid
where
dest = exportPath dir loc
- (destdir, base) = P.splitFileName dest
- template = relatedTemplate (base <> ".tmp")
+ (destdir, base) = splitFileName dest
+ template = relatedTemplate (fromOsPath base <> ".tmp")
-removeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex ()
+removeExportWithContentIdentifierM :: IgnoreInodes -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex ()
removeExportWithContentIdentifierM ii dir k loc removeablecids =
checkExportContent ii dir loc removeablecids (giveup "unsafe to remove modified file") $ \case
DoesNotExist -> return ()
KnownContentIdentifier -> removeExportM dir k loc
-checkPresentExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool
+checkPresentExportWithContentIdentifierM :: IgnoreInodes -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool
checkPresentExportWithContentIdentifierM ii dir _k loc knowncids =
checkPresentGeneric' dir $
checkExportContent ii dir loc knowncids (return False) $ \case
--
-- So, it suffices to check if the destination file's current
-- content is known, and immediately run the callback.
-checkExportContent :: IgnoreInodes -> RawFilePath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a
+checkExportContent :: IgnoreInodes -> OsPath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a
checkExportContent ii dir loc knowncids unsafe callback =
- tryWhenExists (liftIO $ R.getSymbolicLinkStatus dest) >>= \case
+ tryWhenExists (liftIO $ R.getSymbolicLinkStatus (fromOsPath dest)) >>= \case
Just destst
| not (isRegularFile destst) -> unsafe
| otherwise -> catchDefaultIO Nothing (liftIO $ mkContentIdentifier ii dest destst) >>= \case
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S
-import qualified System.FilePath.ByteString as P
import Annex.Common
import Utility.FileMode
import Annex.Tmp
import Utility.Metered
import Utility.Directory.Create
-import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
withCheckedFiles :: (FilePath -> IO Bool) -> FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool
else a chunks
)
withStoredFiles :: FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool
-withStoredFiles = withCheckedFiles doesFileExist
+withStoredFiles = withCheckedFiles (doesFileExist . toOsPath)
{- Splits a ByteString into chunks and writes to dests, obeying configured
- chunk size (not to be confused with the L.ByteString chunk size). -}
feed bytes' (sz - s) ls h
else return (l:ls)
-storeHelper :: FilePath -> (RawFilePath -> RawFilePath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO ()
+storeHelper :: FilePath -> (OsPath -> OsPath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO ()
storeHelper repotop finalizer key storer tmpdir destdir = do
void $ liftIO $ tryIO $ createDirectoryUnder
- [toRawFilePath repotop]
- (toRawFilePath tmpdir)
+ [toOsPath repotop]
+ (toOsPath tmpdir)
Legacy.storeChunks key tmpdir destdir storer recorder (legacyFinalizer finalizer)
where
recorder f s = do
- let f' = toRawFilePath f
+ let f' = toOsPath f
void $ tryIO $ allowWrite f'
writeFile f s
void $ tryIO $ preventWrite f'
-store :: FilePath -> ChunkSize -> (RawFilePath -> RawFilePath -> IO ()) -> Key -> L.ByteString -> MeterUpdate -> FilePath -> FilePath -> IO ()
+store :: FilePath -> ChunkSize -> (OsPath -> OsPath -> IO ()) -> Key -> L.ByteString -> MeterUpdate -> FilePath -> FilePath -> IO ()
store repotop chunksize finalizer k b p = storeHelper repotop finalizer k $ \dests ->
storeLegacyChunked p chunksize dests b
- Done very innefficiently, by writing to a temp file.
- :/ This is legacy code..
-}
-retrieve :: (RawFilePath -> Key -> [RawFilePath]) -> RawFilePath -> Retriever
+retrieve :: (OsPath -> Key -> [OsPath]) -> OsPath -> Retriever
retrieve locations d basek p _dest miv c = withOtherTmp $ \tmpdir -> do
showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow."
- let tmp = tmpdir P.</> keyFile basek <> ".directorylegacy.tmp"
- let tmp' = toOsPath tmp
+ let tmp = tmpdir </> keyFile basek <> literalOsPath ".directorylegacy.tmp"
let go = \k sink -> do
- liftIO $ void $ withStoredFiles (fromRawFilePath d) (legacyLocations locations) k $ \fs -> do
+ liftIO $ void $ withStoredFiles (fromOsPath d) (legacyLocations locations) k $ \fs -> do
forM_ fs $
- F.appendFile' tmp' <=< S.readFile
+ F.appendFile' tmp <=< S.readFile
return True
- b <- liftIO $ F.readFile tmp'
- liftIO $ removeWhenExistsWith R.removeLink tmp
+ b <- liftIO $ F.readFile tmp
+ liftIO $ removeWhenExistsWith removeFile tmp
sink b
byteRetriever go basek p tmp miv c
-checkKey :: RawFilePath -> (RawFilePath -> Key -> [RawFilePath]) -> Key -> Annex Bool
+checkKey :: OsPath -> (OsPath -> Key -> [OsPath]) -> Key -> Annex Bool
checkKey d locations k = liftIO $
- withStoredFiles (fromRawFilePath d) (legacyLocations locations) k $
+ withStoredFiles (fromOsPath d) (legacyLocations locations) k $
-- withStoredFiles checked that it exists
const $ return True
-legacyFinalizer :: (RawFilePath -> RawFilePath -> IO ()) -> (FilePath -> FilePath -> IO ())
-legacyFinalizer f = \a b -> f (toRawFilePath a) (toRawFilePath b)
+legacyFinalizer :: (OsPath -> OsPath -> IO ()) -> (FilePath -> FilePath -> IO ())
+legacyFinalizer f = \a b -> f (toOsPath a) (toOsPath b)
-legacyLocations :: (RawFilePath -> Key -> [RawFilePath]) -> (FilePath -> Key -> [FilePath])
+legacyLocations :: (OsPath -> Key -> [OsPath]) -> (FilePath -> Key -> [FilePath])
legacyLocations locations = \f k ->
- map fromRawFilePath $ locations (toRawFilePath f) k
+ map fromOsPath $ locations (toOsPath f) k
storeKeyM :: External -> Storer
storeKeyM external = fileStorer $ \k f p ->
- either giveup return =<< go k f p
+ either giveup return =<< go k p
+ (\sk -> TRANSFER Upload sk (fromOsPath f))
where
- go k f p = handleRequestKey external (\sk -> TRANSFER Upload sk f) k (Just p) $ \resp ->
+ go k p mkreq = handleRequestKey external mkreq k (Just p) $ \resp ->
case resp of
TRANSFER_SUCCESS Upload k' | k == k' ->
result (Right ())
retrieveKeyFileM external = fileRetriever $ \d k p ->
either giveup return =<< watchFileSize d p (go d k)
where
- go d k p = handleRequestKey external (\sk -> TRANSFER Download sk (fromRawFilePath d)) k (Just p) $ \resp ->
+ go d k p = handleRequestKey external (\sk -> TRANSFER Download sk (fromOsPath d)) k (Just p) $ \resp ->
case resp of
TRANSFER_SUCCESS Download k'
| k == k' -> result $ Right ()
UNSUPPORTED_REQUEST -> result []
_ -> Nothing
-storeExportM :: External -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
+storeExportM :: External -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
storeExportM external f k loc p = either giveup return =<< go
where
go = handleRequestExport external loc req k (Just p) $ \resp -> case resp of
UNSUPPORTED_REQUEST ->
result $ Left "TRANSFEREXPORT not implemented by external special remote"
_ -> Nothing
- req sk = TRANSFEREXPORT Upload sk f
+ req sk = TRANSFEREXPORT Upload sk (fromOsPath f)
-retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification
+retrieveExportM :: External -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification
retrieveExportM external k loc dest p = do
verifyKeyContentIncrementally AlwaysVerify k $ \iv ->
- tailVerify iv (toRawFilePath dest) $
+ tailVerify iv dest $
either giveup return =<< go
where
go = handleRequestExport external loc req k (Just p) $ \resp -> case resp of
UNSUPPORTED_REQUEST ->
result $ Left "TRANSFEREXPORT not implemented by external special remote"
_ -> Nothing
- req sk = TRANSFEREXPORT Download sk dest
+ req sk = TRANSFEREXPORT Download sk (fromOsPath dest)
checkPresentExportM :: External -> Key -> ExportLocation -> Annex Bool
checkPresentExportM external k loc = either giveup id <$> go
handleRemoteRequest (PROGRESS bytesprocessed) =
maybe noop (\a -> liftIO $ a bytesprocessed) mp
handleRemoteRequest (DIRHASH k) =
- send $ VALUE $ fromRawFilePath $ hashDirMixed def k
+ send $ VALUE $ fromOsPath $ hashDirMixed def k
handleRemoteRequest (DIRHASH_LOWER k) =
- send $ VALUE $ fromRawFilePath $ hashDirLower def k
+ send $ VALUE $ fromOsPath $ hashDirLower def k
handleRemoteRequest (SETCONFIG setting value) =
liftIO $ atomically $ do
ParsedRemoteConfig m c <- takeTMVar (externalConfig st)
Just u -> send $ VALUE $ fromUUID u
Nothing -> senderror "cannot send GETUUID here"
handleRemoteRequest GETGITDIR =
- send . VALUE . fromRawFilePath =<< fromRepo Git.localGitDir
+ send . VALUE . fromOsPath =<< fromRepo Git.localGitDir
handleRemoteRequest GETGITREMOTENAME =
case externalRemoteName external of
Just n -> send $ VALUE n
senderror = sendMessage st . ERROR
credstorage setting u = CredPairStorage
- { credPairFile = base
+ { credPairFile = toOsPath base
, credPairEnvironment = (base ++ "login", base ++ "password")
, credPairRemoteField = Accepted setting
}
checkUrlM external url =
handleRequest external (CHECKURL url) Nothing $ \req -> case req of
CHECKURL_CONTENTS sz f -> result $ UrlContents sz $
- if null f then Nothing else Just f
+ if null f then Nothing else Just (toOsPath f)
CHECKURL_MULTI l -> result $ UrlMulti $ map mkmulti l
CHECKURL_FAILURE errmsg -> Just $ giveup $
respErrorMessage "CHECKURL" errmsg
UNSUPPORTED_REQUEST -> giveup "CHECKURL not implemented by external special remote"
_ -> Nothing
where
- mkmulti (u, s, f) = (u, s, f)
+ mkmulti (u, s, f) = (u, s, toOsPath f)
retrieveUrl :: Retriever
retrieveUrl = fileRetriever' $ \f k p iv -> do
us <- getWebUrls k
- unlessM (withUrlOptions $ downloadUrl True k p iv us (fromRawFilePath f)) $
+ unlessM (withUrlOptions $ downloadUrl True k p iv us f) $
giveup "failed to download content"
checkKeyUrl :: CheckPresent
deserialize = parseURIPortable
instance Proto.Serializable ExportLocation where
- serialize = fromRawFilePath . fromExportLocation
- deserialize = Just . mkExportLocation . toRawFilePath
+ serialize = fromOsPath . fromExportLocation
+ deserialize = Just . mkExportLocation . toOsPath
instance Proto.Serializable ExportDirectory where
- serialize = fromRawFilePath . fromExportDirectory
- deserialize = Just . mkExportDirectory . toRawFilePath
+ serialize = fromOsPath . fromExportDirectory
+ deserialize = Just . mkExportDirectory . toOsPath
instance Proto.Serializable ExtensionList where
serialize (ExtensionList l) = unwords l
import qualified Data.Map as M
import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy as L
-import qualified System.FilePath.ByteString as P
import Data.Default
import Annex.Common
import Annex.UUID
import Annex.Ssh
import Annex.Perms
+import Messages.Progress
+import Types.ProposedAccepted
+import Logs.Remote
import qualified Remote.Rsync
import qualified Remote.Directory
import Utility.Rsync
import Utility.Tmp
-import Logs.Remote
import Utility.Gpg
import Utility.SshHost
import Utility.Directory.Create
-import Messages.Progress
-import Types.ProposedAccepted
+import qualified Utility.FileIO as F
remote :: RemoteType
remote = specialRemoteType $ RemoteType
- which is needed for rsync of objects to it to work.
-}
rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do
- createAnnexDirectory (toRawFilePath tmp P.</> objectDir)
+ createAnnexDirectory (tmp </> objectDir)
dummycfg <- liftIO dummyRemoteGitConfig
let (rsynctransport, rsyncurl, _) = rsyncTransport r dummycfg
- let tmpconfig = tmp </> "config"
+ let tmpconfig = fromOsPath $ tmp </> literalOsPath "config"
opts <- rsynctransport
void $ liftIO $ rsync $ opts ++
[ Param $ rsyncurl ++ "/config"
void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig' False)
ok <- liftIO $ rsync $ opts ++
[ Param "--recursive"
- , Param $ tmp ++ "/"
+ , Param $ fromOsPath tmp ++ "/"
, Param rsyncurl
]
unless ok $
store' repo r rsyncopts accessmethod
| not $ Git.repoIsUrl repo =
byteStorer $ \k b p -> guardUsable repo (giveup "cannot access remote") $ liftIO $ do
- let tmpdir = Git.repoPath repo P.</> "tmp" P.</> keyFile k
+ let tmpdir = Git.repoPath repo </> literalOsPath "tmp" </> keyFile k
void $ tryIO $ createDirectoryUnder [Git.repoPath repo] tmpdir
- let tmpf = tmpdir P.</> keyFile k
- meteredWriteFile p (fromRawFilePath tmpf) b
- let destdir = parentDir $ toRawFilePath $ gCryptLocation repo k
+ let tmpf = tmpdir </> keyFile k
+ meteredWriteFile p tmpf b
+ let destdir = parentDir $ gCryptLocation repo k
Remote.Directory.finalizeStoreGeneric (Git.repoPath repo) tmpdir destdir
| Git.repoIsSsh repo = if accessShell r
then fileStorer $ \k f p -> do
oh <- mkOutputHandler
ok <- Ssh.rsyncHelper oh (Just p)
- =<< Ssh.rsyncParamsRemote r Upload k f
+ =<< Ssh.rsyncParamsRemote r Upload k
+ (fromOsPath f)
unless ok $
giveup "rsync failed"
else storersync
retrieve' repo r rsyncopts accessmethod
| not $ Git.repoIsUrl repo = byteRetriever $ \k sink ->
guardUsable repo (giveup "cannot access remote") $
- sink =<< liftIO (L.readFile $ gCryptLocation repo k)
+ sink =<< liftIO (F.readFile $ gCryptLocation repo k)
| Git.repoIsSsh repo = if accessShell r
then fileRetriever $ \f k p -> do
ps <- Ssh.rsyncParamsRemote r Download k
- (fromRawFilePath f)
+ (fromOsPath f)
oh <- mkOutputHandler
unlessM (Ssh.rsyncHelper oh (Just p) ps) $
giveup "rsync failed"
| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $
liftIO $ Remote.Directory.removeDirGeneric True
(gCryptTopDir repo)
- (fromRawFilePath (parentDir (toRawFilePath (gCryptLocation repo k))))
+ (parentDir (gCryptLocation repo k))
| Git.repoIsSsh repo = shellOrRsync r removeshell removersync
| accessmethod == AccessRsyncOverSsh = removersync
| otherwise = unsupportedUrl
checkrsync = Remote.Rsync.checkKey rsyncopts k
checkshell = Ssh.inAnnex repo k
-gCryptTopDir :: Git.Repo -> FilePath
-gCryptTopDir repo = Git.repoLocation repo </> fromRawFilePath objectDir
+gCryptTopDir :: Git.Repo -> OsPath
+gCryptTopDir repo = toOsPath (Git.repoLocation repo) </> objectDir
{- Annexed objects are hashed using lower-case directories for max
- portability. -}
-gCryptLocation :: Git.Repo -> Key -> FilePath
+gCryptLocation :: Git.Repo -> Key -> OsPath
gCryptLocation repo key = gCryptTopDir repo
- </> fromRawFilePath (keyPath key (hashDirLower def))
+ </> keyPath key (hashDirLower def)
data AccessMethod = AccessRsyncOverSsh | AccessGitAnnexShell
deriving (Eq)
let (rsynctransport, rsyncurl, _) = rsyncTransport r gc
opts <- rsynctransport
liftIO $ do
- withTmpFile (toOsPath "tmpconfig") $ \tmpconfig _ -> do
- let tmpconfig' = fromRawFilePath $ fromOsPath tmpconfig
+ withTmpFile (literalOsPath "tmpconfig") $ \tmpconfig _ -> do
+ let tmpconfig' = fromOsPath tmpconfig
void $ rsync $ opts ++
[ Param $ rsyncurl ++ "/config"
, Param tmpconfig'
import Utility.Metered
import Utility.Env
import Utility.Batch
+import qualified Utility.FileIO as F
import Remote.Helper.Git
import Remote.Helper.Messages
import Remote.Helper.ExportImport
geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do
let url = Git.repoLocation r ++ "/config"
- v <- withTmpFile (toOsPath "git-annex.tmp") $ \tmpfile h -> do
+ v <- withTmpFile (literalOsPath "git-annex.tmp") $ \tmpfile h -> do
liftIO $ hClose h
- let tmpfile' = fromRawFilePath $ fromOsPath tmpfile
- Url.download' nullMeterUpdate Nothing url tmpfile' uo >>= \case
+ Url.download' nullMeterUpdate Nothing url tmpfile uo >>= \case
Right () ->
pipedconfig Git.Config.ConfigNullList
False url "git"
, Param "--null"
, Param "--list"
, Param "--file"
- , File tmpfile'
+ , File (fromOsPath tmpfile)
] >>= return . \case
Right r' -> Right r'
Left exitcode -> Left $ "git config exited " ++ show exitcode
| remoteAnnexBare remoteconfig == Just False = annexLocationsNonBare gc key
| otherwise = annexLocationsBare gc key
#ifndef mingw32_HOST_OS
- locs' = map fromRawFilePath locs
+ locs' = map fromOsPath locs
#else
- locs' = map (replace "\\" "/" . fromRawFilePath) locs
+ locs' = map (replace "\\" "/" . fromOsPath) locs
#endif
remoteconfig = gitconfig r
failedlock = giveup "can't lock content"
{- Tries to copy a key's content from a remote's annex to a file. -}
-copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+copyFromRemote :: Remote -> State -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
copyFromRemote r st key file dest meterupdate vc = do
repo <- getRepo r
copyFromRemote'' repo r st key file dest meterupdate vc
-copyFromRemote'' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+copyFromRemote'' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
copyFromRemote'' repo r st@(State connpool _ _ _ _) key af dest meterupdate vc
| isP2PHttp r = copyp2phttp
| Git.repoIsHttp repo = verifyKeyContentIncrementally vc key $ \iv -> do
<|> remoteAnnexBwLimit (gitconfig r)
copyp2phttp = verifyKeyContentIncrementally vc key $ \iv -> do
- startsz <- liftIO $ tryWhenExists $
- getFileSize (toRawFilePath dest)
- bracketIO (openBinaryFile dest ReadWriteMode) (hClose) $ \h -> do
+ startsz <- liftIO $ tryWhenExists $ getFileSize dest
+ bracketIO (F.openBinaryFile dest ReadWriteMode) (hClose) $ \h -> do
metered (Just meterupdate) key bwlimit $ \_ p -> do
p' <- case startsz of
Just startsz' -> liftIO $ do
Valid -> return ()
Invalid -> giveup "Transfer failed"
-copyFromRemoteCheap :: State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ())
+copyFromRemoteCheap :: State -> Git.Repo -> Maybe (Key -> AssociatedFile -> OsPath -> Annex ())
#ifndef mingw32_HOST_OS
copyFromRemoteCheap st repo
| not $ Git.repoIsUrl repo = Just $ \key _af file -> guardUsable repo (giveup "cannot access remote") $ do
gc <- getGitConfigFromState st
loc <- liftIO $ gitAnnexLocation key repo gc
- liftIO $ ifM (R.doesPathExist loc)
+ liftIO $ ifM (doesFileExist loc)
( do
absloc <- absPath loc
- R.createSymbolicLink absloc (toRawFilePath file)
+ R.createSymbolicLink
+ (fromOsPath absloc)
+ (fromOsPath file)
, giveup "remote does not contain key"
)
| otherwise = Nothing
#endif
{- Tries to copy a key's content to a remote's annex. -}
-copyToRemote :: Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
+copyToRemote :: Remote -> State -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()
copyToRemote r st key af o meterupdate = do
repo <- getRepo r
copyToRemote' repo r st key af o meterupdate
-copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
+copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()
copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate
| isP2PHttp r = prepsendwith copyp2phttp
| not $ Git.repoIsUrl repo = ifM duc
Nothing -> return True
logStatusAfter NoLiveUpdate key $ Annex.Content.getViaTmp rsp verify key af (Just sz) $ \dest ->
metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' ->
- copier object (fromRawFilePath dest) key p' checksuccess verify
+ copier object dest key p' checksuccess verify
)
unless res $
failedsend
r' <- Git.Config.read r
environ <- getEnvironment
let environ' = addEntries
- [ ("GIT_WORK_TREE", fromRawFilePath $ Git.repoPath r')
- , ("GIT_DIR", fromRawFilePath $ Git.localGitDir r')
+ [ ("GIT_WORK_TREE", fromOsPath $ Git.repoPath r')
+ , ("GIT_DIR", fromOsPath $ Git.localGitDir r')
] environ
- batchCommandEnv program (Param "fsck" : params) (Just environ')
+ batchCommandEnv (fromOsPath program)
+ (Param "fsck" : params)
+ (Just environ')
{- The passed repair action is run in the Annex monad of the remote. -}
repairRemote :: Git.Repo -> Annex Bool -> Annex (IO Bool)
-- because they can be modified at any time.
<&&> (not <$> annexThin <$> Annex.getGitConfig)
-type FileCopier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification)
+type FileCopier = OsPath -> OsPath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification)
-- If either the remote or local repository wants to use hard links,
-- the copier will do so (falling back to copying if a hard link cannot be
mkFileCopier :: Bool -> State -> Annex FileCopier
mkFileCopier remotewanthardlink (State _ _ copycowtried _ _) = do
localwanthardlink <- wantHardLink
- let linker = \src dest -> R.createLink (toRawFilePath src) (toRawFilePath dest) >> return True
+ let linker = \src dest -> R.createLink (fromOsPath src) (fromOsPath dest) >> return True
if remotewanthardlink || localwanthardlink
then return $ \src dest k p check verifyconfig ->
ifM (liftIO (catchBoolIO (linker src dest)))
( ifM check
( return (True, Verified)
, do
- verificationOfContentFailed (toRawFilePath dest)
+ verificationOfContentFailed dest
return (False, UnVerified)
)
, copier src dest k p check verifyconfig
where
copier src dest k p check verifyconfig = do
iv <- startVerifyKeyContentIncrementally verifyconfig k
- liftIO (fileCopier copycowtried src dest p iv) >>= \case
+ liftIO (fileCopier copycowtried (fromOsPath src) (fromOsPath dest) p iv) >>= \case
Copied -> ifM check
( finishVerifyKeyContentIncrementally iv
, do
- verificationOfContentFailed (toRawFilePath dest)
+ verificationOfContentFailed dest
return (False, UnVerified)
)
CopiedCoW -> unVerified check
import qualified Annex
import qualified Git
import qualified Git.Types as Git
+import qualified Git.Config
import qualified Git.Url
import qualified Git.Remote
import qualified Git.GCrypt
import Annex.UUID
import Crypto
import Backend.Hash
+import Logs.Remote
+import Logs.RemoteState
import Utility.Hash
import Utility.SshHost
import Utility.Url
-import Logs.Remote
-import Logs.RemoteState
-import qualified Git.Config
+import qualified Utility.FileIO as F
import qualified Network.GitLFS as LFS
import Control.Concurrent.STM
| isEncKey k = Nothing
| otherwise = fromKey keySize k
-mkUploadRequest :: RemoteStateHandle -> Key -> FilePath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer)
+mkUploadRequest :: RemoteStateHandle -> Key -> OsPath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer)
mkUploadRequest rs k content = case (extractKeySha256 k, extractKeySize k) of
(Just sha256, Just size) ->
ret sha256 size
ret sha256 size
_ -> do
sha256 <- calcsha256
- size <- liftIO $ getFileSize (toRawFilePath content)
+ size <- liftIO $ getFileSize content
rememberboth sha256 size
ret sha256 size
where
- calcsha256 = liftIO $ T.pack . show . sha2_256 <$> L.readFile content
+ calcsha256 = liftIO $ T.pack . show . sha2_256 <$> F.readFile content
ret sha256 size = do
let obj = LFS.TransferRequestObject
{ LFS.req_oid = sha256
Nothing -> giveup "unable to parse git-lfs server download url"
Just req -> do
uo <- getUrlOptions
- liftIO $ downloadConduit p iv req (fromRawFilePath dest) uo
+ liftIO $ downloadConduit p iv req dest uo
-- Since git-lfs does not support removing content, nothing needs to be
-- done to lock content in the remote, except for checking that the content
forceSuccessProcess cmd pid
go' _ _ _ _ _ = error "internal"
-retrieve :: forall a. Remote -> Key -> MeterUpdate -> RawFilePath -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a
+retrieve :: forall a. Remote -> Key -> MeterUpdate -> OsPath -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a
retrieve = byteRetriever . retrieve'
retrieve' :: forall a. Remote -> Key -> (L.ByteString -> Annex a) -> Annex a
creds :: UUID -> CredPairStorage
creds u = CredPairStorage
- { credPairFile = fromUUID u
+ { credPairFile = literalOsPath (fromUUID u)
, credPairEnvironment = ("AWS_ACCESS_KEY_ID", "AWS_SECRET_ACCESS_KEY")
, credPairRemoteField = s3credsField
}
import Backend (isStableKey)
import Annex.SpecialRemote.Config
import Annex.Verify
-import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
-> ChunkConfig
-> EncKey
-> Key
- -> FilePath
+ -> OsPath
-> MeterUpdate
-> Maybe (Cipher, EncKey)
-> encc
-- possible without this check.
(UnpaddedChunks chunksize) -> ifM (isStableKey k)
( do
- h <- liftIO $ openBinaryFile f ReadMode
+ h <- liftIO $ F.openBinaryFile f ReadMode
go chunksize h
liftIO $ hClose h
, storechunk k (FileContent f) p
-> ChunkConfig
-> EncKey
-> Key
- -> FilePath
+ -> OsPath
-> MeterUpdate
-> Maybe (Cipher, EncKey)
-> encc
where
go pe cks = do
let ls = map chunkKeyList cks
- currsize <- liftIO $ catchMaybeIO $ getFileSize (toRawFilePath dest)
+ currsize <- liftIO $ catchMaybeIO $ getFileSize dest
let ls' = maybe ls (setupResume ls) currsize
if any null ls'
-- dest is already complete
-- passing the whole file content to the
-- incremental verifier though.
Nothing -> do
- retriever (encryptor basek) basep (toRawFilePath dest) iv $
+ retriever (encryptor basek) basep dest iv $
retrieved iv Nothing basep
return $ case iv of
Nothing -> Right iv
opennew = do
iv <- startVerifyKeyContentIncrementally vc basek
- h <- liftIO $ openBinaryFile dest WriteMode
+ h <- liftIO $ F.openBinaryFile dest WriteMode
return (h, iv)
-- Open the file and seek to the start point in order to resume.
openresume startpoint = do
-- ReadWriteMode allows seeking; AppendMode does not.
- h <- liftIO $ openBinaryFile dest ReadWriteMode
+ h <- liftIO $ F.openBinaryFile dest ReadWriteMode
liftIO $ hSeek h AbsoluteSeek startpoint
-- No incremental verification when resuming, since that
-- would need to read up to the startpoint.
-}
writeRetrievedContent
:: LensEncParams encc
- => FilePath
+ => OsPath
-> Maybe (Cipher, EncKey)
-> encc
-> Maybe Handle
writeRetrievedContent dest enc encc mh mp content miv = case (enc, mh, content) of
(Nothing, Nothing, FileContent f)
| f == dest -> noop
- | otherwise -> liftIO $ moveFile (toRawFilePath f) (toRawFilePath dest)
+ | otherwise -> liftIO $ moveFile f dest
(Just (cipher, _), _, ByteContent b) -> do
cmd <- gpgCmd <$> Annex.getGitConfig
decrypt cmd encc cipher (feedBytes b) $
withBytes content $ \b ->
decrypt cmd encc cipher (feedBytes b) $
readBytes write
- liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
+ liftIO $ removeWhenExistsWith removeFile f
(Nothing, _, FileContent f) -> do
withBytes content write
- liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
+ liftIO $ removeWhenExistsWith removeFile f
(Nothing, _, ByteContent b) -> write b
where
write b = case mh of
Nothing -> S.hPut h
in meteredWrite p writer b
Nothing -> L.hPut h b
- opendest = openBinaryFile dest WriteMode
+ opendest = F.openBinaryFile dest WriteMode
{- Can resume when the chunk's offset is at or before the end of
- the dest file. -}
withBytes :: ContentSource -> (L.ByteString -> Annex a) -> Annex a
withBytes (ByteContent b) a = a b
-withBytes (FileContent f) a = a =<< liftIO (L.readFile f)
+withBytes (FileContent f) a = a =<< liftIO (F.readFile f)
when (null stored) $
giveup "no chunks were stored"
where
- basef = tmp ++ fromRawFilePath (keyFile key)
+ basef = tmp ++ fromOsPath (keyFile key)
tmpdests = map (basef ++ ) chunkStream
{- Given a list of destinations to use, chunks the data according to the
import System.PosixCompat.Files (modificationTime)
import qualified Data.Map as M
import qualified Data.Set as S
-import qualified System.FilePath.ByteString as P
repoCheap :: Git.Repo -> Bool
repoCheap = not . Git.repoIsUrl
-localpathCalc :: Git.Repo -> Maybe FilePath
+localpathCalc :: Git.Repo -> Maybe OsPath
localpathCalc r
| not (Git.repoIsLocal r) && not (Git.repoIsLocalUnknown r) = Nothing
- | otherwise = Just $ fromRawFilePath $ Git.repoPath r
+ | otherwise = Just $ Git.repoPath r
{- Checks relatively inexpensively if a repository is available for use. -}
repoAvail :: Git.Repo -> Annex Availability
gitRepoInfo :: Remote -> Annex [(String, String)]
gitRepoInfo r = do
d <- fromRepo Git.localGitDir
- mtimes <- liftIO $ mapM (\p -> modificationTime <$> R.getFileStatus p)
- =<< emptyWhenDoesNotExist (dirContentsRecursive (d P.</> "refs" P.</> "remotes" P.</> encodeBS (Remote.name r)))
+ let refsdir = d </> literalOsPath "refs"
+ </> literalOsPath "remotes"
+ </> toOsPath (Remote.name r)
+ mtimes <- liftIO $ mapM (\p -> modificationTime <$> R.getFileStatus (fromOsPath p))
+ =<< emptyWhenDoesNotExist (dirContentsRecursive refsdir)
let lastsynctime = case mtimes of
[] -> "never"
_ -> show $ posixSecondsToUTCTime $ realToFrac $ maximum mtimes
module Remote.Helper.Hooks (addHooks) where
import qualified Data.Map as M
-import qualified System.FilePath.ByteString as P
import Annex.Common
import Types.Remote
runHooks :: Remote -> Maybe String -> Maybe String -> Annex a -> Annex a
runHooks r starthook stophook a = do
dir <- fromRepo gitAnnexRemotesDir
- let lck = dir P.</> remoteid <> ".lck"
+ let lck = dir </> remoteid <> literalOsPath ".lck"
whenM (notElem lck . M.keys <$> getLockCache) $ do
createAnnexDirectory dir
firstrun lck
import Remote.Helper.Special
import Utility.Metered
import Utility.Hash (IncrementalVerifier(..))
+import qualified Utility.FileIO as F
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S
-- Reads the file and generates a streaming request body, that will update
-- the meter as it's sent.
-httpBodyStorer :: FilePath -> MeterUpdate -> IO RequestBody
+httpBodyStorer :: OsPath -> MeterUpdate -> IO RequestBody
httpBodyStorer src m = do
- size <- getFileSize (toRawFilePath src)
+ size <- getFileSize src
let streamer sink = withMeteredFile src m $ \b -> byteStringPopper b sink
return $ RequestBodyStream (fromInteger size) streamer
-- Like httpBodyStorer, but generates a chunked request body.
-httpBodyStorerChunked :: FilePath -> MeterUpdate -> RequestBody
+httpBodyStorerChunked :: OsPath -> MeterUpdate -> RequestBody
httpBodyStorerChunked src m =
let streamer sink = withMeteredFile src m $ \b -> byteStringPopper b sink
in RequestBodyStreamChunked streamer
-- Reads the http body and stores it to the specified file, updating the
-- meter and incremental verifier as it goes.
-httpBodyRetriever :: FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Response BodyReader -> IO ()
+httpBodyRetriever :: OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> Response BodyReader -> IO ()
httpBodyRetriever dest meterupdate iv resp
| responseStatus resp /= ok200 = giveup $ show $ responseStatus resp
- | otherwise = bracket (openBinaryFile dest WriteMode) hClose (go zeroBytesProcessed)
+ | otherwise = bracket (F.openBinaryFile dest WriteMode) hClose (go zeroBytesProcessed)
where
reader = responseBody resp
go sofar h = do
-- the pool when done.
type WithConn a c = (ClosableConnection c -> Annex (ClosableConnection c, a)) -> Annex a
-store :: UUID -> RemoteGitConfig -> ProtoRunner (Maybe [UUID]) -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
+store :: UUID -> RemoteGitConfig -> ProtoRunner (Maybe [UUID]) -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()
store remoteuuid gc runner k af o p = do
- let sizer = KeySizer k (fmap (toRawFilePath . fst3) <$> prepSendAnnex k o)
+ let sizer = KeySizer k (fmap fst3 <$> prepSendAnnex k o)
let bwlimit = remoteAnnexBwLimitUpload gc <|> remoteAnnexBwLimit gc
metered (Just p) sizer bwlimit $ \_ p' ->
runner (P2P.put k af p') >>= \case
when (u /= remoteuuid) $
logChange lu k u logstatus
-retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
retrieve gc runner k af dest p verifyconfig = do
iv <- startVerifyKeyContentIncrementally verifyconfig k
let bwlimit = remoteAnnexBwLimitDownload gc <|> remoteAnnexBwLimit gc
import Annex.Common
import Types.Availability
-checkPathAvailability :: Bool -> FilePath -> Annex Availability
+checkPathAvailability :: Bool -> OsPath -> Annex Availability
checkPathAvailability islocal d
| not islocal = return GloballyAvailable
| otherwise = ifM (liftIO $ doesDirectoryExist d)
}
| otherwise = r
-readonlyStoreKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
+readonlyStoreKey :: Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()
readonlyStoreKey _ _ _ _ = readonlyFail
readonlyRemoveKey :: Maybe SafeDropProof -> Key -> Annex ()
readonlyStorer :: Storer
readonlyStorer _ _ _ = readonlyFail
-readonlyStoreExport :: FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
+readonlyStoreExport :: OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
readonlyStoreExport _ _ _ _ = readonlyFail
readonlyRemoveExport :: Key -> ExportLocation -> Annex ()
readonlyRemoveExportDirectory :: ExportDirectory -> Annex ()
readonlyRemoveExportDirectory _ = readonlyFail
-readonlyStoreExportWithContentIdentifier :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
+readonlyStoreExportWithContentIdentifier :: OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
readonlyStoreExportWithContentIdentifier _ _ _ _ _ = readonlyFail
readonlyRemoveExportWithContentIdentifier :: Key -> ExportLocation -> [ContentIdentifier] -> Annex ()
import qualified Git
import qualified Git.Construct
import Git.Types
+import qualified Utility.FileIO as F
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
-- A Storer that expects to be provided with a file containing
-- the content of the key to store.
-fileStorer :: (Key -> FilePath -> MeterUpdate -> Annex ()) -> Storer
+fileStorer :: (Key -> OsPath -> MeterUpdate -> Annex ()) -> Storer
fileStorer a k (FileContent f) m = a k f m
fileStorer a k (ByteContent b) m = withTmp k $ \f -> do
- let f' = fromRawFilePath f
- liftIO $ L.writeFile f' b
- a k f' m
+ liftIO $ L.writeFile (fromOsPath f) b
+ a k f m
-- A Storer that expects to be provided with a L.ByteString of
-- the content to store.
-- A Retriever that generates a lazy ByteString containing the Key's
-- content, and passes it to a callback action which will fully consume it
-- before returning.
-byteRetriever :: (Key -> (L.ByteString -> Annex a) -> Annex a) -> Key -> MeterUpdate -> RawFilePath -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a
+byteRetriever :: (Key -> (L.ByteString -> Annex a) -> Annex a) -> Key -> MeterUpdate -> OsPath -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a
byteRetriever a k _m _dest _miv callback = a k (callback . ByteContent)
-- A Retriever that writes the content of a Key to a file.
-- retrieves data. The incremental verifier is updated in the background as
-- the action writes to the file, but may not be updated with the entire
-- content of the file.
-fileRetriever :: (RawFilePath -> Key -> MeterUpdate -> Annex ()) -> Retriever
+fileRetriever :: (OsPath -> Key -> MeterUpdate -> Annex ()) -> Retriever
fileRetriever a = fileRetriever' $ \f k m miv ->
let retrieve = a f k m
in tailVerify miv f retrieve
- The action is responsible for updating the progress meter and the
- incremental verifier as it retrieves data.
-}
-fileRetriever' :: (RawFilePath -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> Annex ()) -> Retriever
+fileRetriever' :: (OsPath -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> Annex ()) -> Retriever
fileRetriever' a k m dest miv callback = do
createAnnexDirectory (parentDir dest)
a dest k m miv
- pruneTmpWorkDirBefore dest (callback . FileContent . fromRawFilePath)
+ pruneTmpWorkDirBefore dest (callback . FileContent)
{- The base Remote that is provided to specialRemote needs to have
- storeKey, retrieveKeyFile, removeKey, and checkPresent methods,
- but they are never actually used (since specialRemote replaces them).
- Here are some dummy ones.
-}
-storeKeyDummy :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
+storeKeyDummy :: Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()
storeKeyDummy _ _ _ _ = error "missing storeKey implementation"
-retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+retrieveKeyFileDummy :: Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
retrieveKeyFileDummy _ _ _ _ _ = error "missing retrieveKeyFile implementation"
removeKeyDummy :: Maybe SafeDropProof -> Key -> Annex ()
removeKeyDummy _ _ = error "missing removeKey implementation"
displayprogress bwlimit p k srcfile a
| displayProgress cfg = do
- metered (Just p) (KeySizer k (pure (fmap toRawFilePath srcfile))) bwlimit (const a)
+ metered (Just p) (KeySizer k (pure srcfile)) bwlimit (const a)
| otherwise = a p
withBytes :: ContentSource -> (L.ByteString -> Annex a) -> Annex a
withBytes (ByteContent b) a = a b
-withBytes (FileContent f) a = a =<< liftIO (L.readFile f)
+withBytes (FileContent f) a = a =<< liftIO (F.readFile f)
let params' = case (debugenabled, debugselector) of
(True, NoDebugSelector) -> Param "--debug" : params
_ -> params
- return (Param command : File (fromRawFilePath dir) : params')
+ return (Param command : File (fromOsPath dir) : params')
uuidcheck NoUUID = []
uuidcheck u@(UUID _) = ["--uuid", fromUUID u]
fieldopts
import Types.Import
import Crypto (isEncKey)
import Utility.Metered
-
-import qualified System.FilePath.ByteString as P
-import qualified Data.ByteString as S
+import qualified Utility.OsString as OS
-- When a remote is thirdPartyPopulated, the files we want are probably
-- in the .git directory. But, git does not really support .git in paths
-- And so anything in .git is prevented from being imported.
-- To work around that, this renames that directory when generating an
-- ImportLocation.
-mkThirdPartyImportLocation :: RawFilePath -> ImportLocation
+mkThirdPartyImportLocation :: OsPath -> ImportLocation
mkThirdPartyImportLocation =
- mkImportLocation . P.joinPath . map esc . P.splitDirectories
+ mkImportLocation . joinPath . map esc . splitDirectories
where
- esc ".git" = "dotgit"
esc x
- | "dotgit" `S.isSuffixOf` x = "dot" <> x
+ | x == literalOsPath ".git" = literalOsPath "dotgit"
+ | literalOsPath "dotgit" `OS.isSuffixOf` x = literalOsPath "dot" <> x
| otherwise = x
-fromThirdPartyImportLocation :: ImportLocation -> RawFilePath
+fromThirdPartyImportLocation :: ImportLocation -> OsPath
fromThirdPartyImportLocation =
- P.joinPath . map unesc . P.splitDirectories . fromImportLocation
+ joinPath . map unesc . splitDirectories . fromImportLocation
where
- unesc "dotgit" = ".git"
unesc x
- | "dotgit" `S.isSuffixOf` x = S.drop 3 x
+ | x == literalOsPath "dotgit" = literalOsPath ".git"
+ | literalOsPath "dotgit" `OS.isSuffixOf` x = OS.drop 3 x
| otherwise = x
-- When a remote is thirdPartyPopulated, and contains a backup of a
importKey :: ImportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key)
importKey loc _cid sz _ = return $ importKey' (fromImportLocation loc) (Just sz)
-importKey' :: RawFilePath -> Maybe ByteSize -> Maybe Key
+importKey' :: OsPath -> Maybe ByteSize -> Maybe Key
importKey' p msz = case fileKey f of
Just k
-- Annex objects always are in a subdirectory with the same
-- part of special remotes that don't use that layout. The most
-- likely special remote to be in a backup, the directory
-- special remote, does use that layout at least.)
- | lastMaybe (P.splitDirectories (P.dropFileName p)) /= Just f -> Nothing
+ | lastMaybe (splitDirectories (dropFileName p)) /= Just f -> Nothing
-- Chunked or encrypted keys used in special remotes are not
-- supported.
| isChunkKey k || isEncKey k -> Nothing
_ -> Just k
Nothing -> Nothing
where
- f = P.takeFileName p
+ f = takeFileName p
]
fileenv Nothing = []
fileenv (Just file) = [envvar "FILE" file]
- hashbits = map takeDirectory $ splitPath $
- fromRawFilePath $ hashDirMixed def k
+ hashbits = map (fromOsPath . takeDirectory) $
+ splitPath $ hashDirMixed def k
lookupHook :: HookName -> Action -> Annex (Maybe String)
lookupHook hookname action = do
)
store :: HookName -> Storer
-store h = fileStorer $ \k src _p -> runHook h "store" k (Just src)
+store h = fileStorer $ \k src _p -> runHook h "store" k (Just (fromOsPath src))
retrieve :: HookName -> Retriever
retrieve h = fileRetriever $ \d k _p ->
- unlessM (runHook' h "retrieve" k (Just (fromRawFilePath d)) $ return True) $
+ unlessM (runHook' h "retrieve" k (Just (fromOsPath d)) $ return True) $
giveup "failed to retrieve content"
remove :: HookName -> Remover
downloadKey :: Maybe URLString -> LearnedLayout -> Retriever
downloadKey baseurl ll = fileRetriever' $ \dest key p iv ->
- downloadAction (fromRawFilePath dest) p iv (keyUrlAction baseurl ll key)
+ downloadAction dest p iv (keyUrlAction baseurl ll key)
-retriveExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification
+retriveExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification
retriveExportHttpAlso baseurl key loc dest p = do
verifyKeyContentIncrementally AlwaysVerify key $ \iv ->
downloadAction dest p iv (exportLocationUrlAction baseurl loc)
-downloadAction :: FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex ()
+downloadAction :: OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex ()
downloadAction dest p iv run =
Url.withUrlOptions $ \uo ->
run (\url -> Url.download' p iv url dest uo)
-> (URLString -> Annex (Either String ()))
-> Annex (Either String ())
exportLocationUrlAction (Just baseurl) loc a =
- a (baseurl P.</> fromRawFilePath (fromExportLocation loc))
+ a (baseurl P.</> fromOsPath (fromExportLocation loc))
exportLocationUrlAction Nothing _ _ = noBaseUrlError
-- cannot normally happen
]
]
where
- mkurl k hasher = baseurl P.</> fromRawFilePath (hasher k) P.</> kf k
- kf k = fromRawFilePath (keyFile k)
+ mkurl k hasher = baseurl P.</> fromOsPath (hasher k) P.</> kf k
+ kf k = fromOsPath (keyFile k)
, getRepo = return r
, gitconfig = gc
, localpath = if islocal
- then Just $ rsyncUrl o
+ then Just $ toOsPath $ rsyncUrl o
else Nothing
, readonly = False
, appendonly = False
, untrustworthy = False
- , availability = checkPathAvailability islocal (rsyncUrl o)
+ , availability = checkPathAvailability islocal
+ (toOsPath (rsyncUrl o))
, remotetype = remote
, mkUnavailable = return Nothing
, getInfo = return [("url", url)]
- (When we have the right hash directory structure, we can just
- pass --include=X --include=X/Y --include=X/Y/file --exclude=*)
-}
-store :: RsyncOpts -> Key -> FilePath -> MeterUpdate -> Annex ()
+store :: RsyncOpts -> Key -> OsPath -> MeterUpdate -> Annex ()
store o k src meterupdate = storeGeneric o meterupdate basedest populatedest
where
- basedest = fromRawFilePath $ NE.head (keyPaths k)
+ basedest = NE.head (keyPaths k)
populatedest dest = liftIO $ if canrename
then do
- R.rename (toRawFilePath src) (toRawFilePath dest)
+ R.rename (fromOsPath src) (fromOsPath dest)
return True
- else createLinkOrCopy (toRawFilePath src) (toRawFilePath dest)
+ else createLinkOrCopy src dest
{- If the key being sent is encrypted or chunked, the file
- containing its content is a temp file, and so can be
- renamed into place. Otherwise, the file is the annexed
- object file, and has to be copied or hard linked into place. -}
canrename = isEncKey k || isChunkKey k
-storeGeneric :: RsyncOpts -> MeterUpdate -> FilePath -> (FilePath -> Annex Bool) -> Annex ()
+storeGeneric :: RsyncOpts -> MeterUpdate -> OsPath -> (OsPath -> Annex Bool) -> Annex ()
storeGeneric o meterupdate basedest populatedest =
unlessM (storeGeneric' o meterupdate basedest populatedest) $
giveup "failed to rsync content"
-storeGeneric' :: RsyncOpts -> MeterUpdate -> FilePath -> (FilePath -> Annex Bool) -> Annex Bool
+storeGeneric' :: RsyncOpts -> MeterUpdate -> OsPath -> (OsPath -> Annex Bool) -> Annex Bool
storeGeneric' o meterupdate basedest populatedest = withRsyncScratchDir $ \tmp -> do
let dest = tmp </> basedest
- createAnnexDirectory (parentDir (toRawFilePath dest))
+ createAnnexDirectory (parentDir dest)
ok <- populatedest dest
ps <- sendParams
if ok
then showResumable $ rsyncRemote Upload o (Just meterupdate) $ ps ++
Param "--recursive" : partialParams ++
-- tmp/ to send contents of tmp dir
- [ File $ addTrailingPathSeparator tmp
+ [ File $ fromOsPath $ addTrailingPathSeparator tmp
, Param $ rsyncUrl o
]
else return False
-retrieve :: RsyncOpts -> RawFilePath -> Key -> MeterUpdate -> Annex ()
-retrieve o f k p = rsyncRetrieveKey o k (fromRawFilePath f) (Just p)
+retrieve :: RsyncOpts -> OsPath -> Key -> MeterUpdate -> Annex ()
+retrieve o f k p = rsyncRetrieveKey o k f (Just p)
-retrieveCheap :: RsyncOpts -> Key -> AssociatedFile -> FilePath -> Annex ()
+retrieveCheap :: RsyncOpts -> Key -> AssociatedFile -> OsPath -> Annex ()
retrieveCheap o k _af f = ifM (preseedTmp k f)
( rsyncRetrieveKey o k f Nothing
, giveup "cannot preseed rsync with existing content"
remove o _proof k = removeGeneric o includes
where
includes = concatMap use dirHashes
- use h = let dir = fromRawFilePath (h def k) in
- [ fromRawFilePath (parentDir (toRawFilePath dir))
- , dir
+ use h = let dir = h def k in
+ [ fromOsPath (parentDir dir)
+ , fromOsPath dir
-- match content directory and anything in it
- , dir </> fromRawFilePath (keyFile k) </> "***"
+ , fromOsPath $ dir </> keyFile k </> literalOsPath "***"
]
{- An empty directory is rsynced to make it delete. Everything is excluded,
[ Param "--exclude=*" -- exclude everything else
, Param "--quiet", Param "--delete", Param "--recursive"
] ++ partialParams ++
- [ Param $ addTrailingPathSeparator tmp
+ [ Param $ fromOsPath $ addTrailingPathSeparator tmp
, Param $ rsyncUrl o
]
unless ok $
}
in withCreateProcess p $ \_ _ _ -> checkSuccessProcess
-storeExportM :: RsyncOpts -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
+storeExportM :: RsyncOpts -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
storeExportM o src _k loc meterupdate =
storeGeneric o meterupdate basedest populatedest
where
- basedest = fromRawFilePath (fromExportLocation loc)
- populatedest = liftIO . createLinkOrCopy (toRawFilePath src) . toRawFilePath
+ basedest = fromExportLocation loc
+ populatedest = liftIO . createLinkOrCopy src
-retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification
+retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification
retrieveExportM o k loc dest p =
verifyKeyContentIncrementally AlwaysVerify k $ \iv ->
- tailVerify iv (toRawFilePath dest) $
+ tailVerify iv dest $
rsyncRetrieve o [rsyncurl] dest (Just p)
where
- rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc))
+ rsyncurl = mkRsyncUrl o (fromOsPath (fromExportLocation loc))
checkPresentExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool
checkPresentExportM o _k loc = checkPresentGeneric o [rsyncurl]
where
- rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc))
+ rsyncurl = mkRsyncUrl o (fromOsPath (fromExportLocation loc))
removeExportM :: RsyncOpts -> Key -> ExportLocation -> Annex ()
removeExportM o _k loc =
- removeGeneric o $ map fromRawFilePath $
- includes $ fromExportLocation loc
+ removeGeneric o $ map fromOsPath $ includes $ fromExportLocation loc
where
includes f = f : case upFrom f of
Nothing -> []
Just f' -> includes f'
removeExportDirectoryM :: RsyncOpts -> ExportDirectory -> Annex ()
-removeExportDirectoryM o ed = removeGeneric o (allbelow d : includes d)
+removeExportDirectoryM o ed = removeGeneric o $
+ map fromOsPath (allbelow d : includes d)
where
- d = fromRawFilePath $ fromExportDirectory ed
- allbelow f = f </> "***"
- includes f = f : case upFrom (toRawFilePath f) of
+ d = fromExportDirectory ed
+ allbelow f = f </> literalOsPath "***"
+ includes f = f : case upFrom f of
Nothing -> []
- Just f' -> includes (fromRawFilePath f')
+ Just f' -> includes f'
renameExportM :: RsyncOpts -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
renameExportM _ _ _ _ = return Nothing
{- Runs an action in an empty scratch directory that can be used to build
- up trees for rsync. -}
-withRsyncScratchDir :: (FilePath -> Annex a) -> Annex a
+withRsyncScratchDir :: (OsPath -> Annex a) -> Annex a
withRsyncScratchDir a = do
- t <- fromRawFilePath <$> fromRepo gitAnnexTmpObjectDir
- withTmpDirIn t (toOsPath "rsynctmp") a
+ t <- fromRepo gitAnnexTmpObjectDir
+ withTmpDirIn t (literalOsPath "rsynctmp") a
-rsyncRetrieve :: RsyncOpts -> [RsyncUrl] -> FilePath -> Maybe MeterUpdate -> Annex ()
+rsyncRetrieve :: RsyncOpts -> [RsyncUrl] -> OsPath -> Maybe MeterUpdate -> Annex ()
rsyncRetrieve o rsyncurls dest meterupdate =
unlessM go $
giveup "rsync failed"
-- use inplace when retrieving to support resuming
[ Param "--inplace"
, Param u
- , File dest
+ , File (fromOsPath dest)
]
-rsyncRetrieveKey :: RsyncOpts -> Key -> FilePath -> Maybe MeterUpdate -> Annex ()
+rsyncRetrieveKey :: RsyncOpts -> Key -> OsPath -> Maybe MeterUpdate -> Annex ()
rsyncRetrieveKey o k dest meterupdate =
rsyncRetrieve o (rsyncUrls o k) dest meterupdate
import Utility.Rsync
import Utility.SafeCommand
import Utility.ShellEscape
-import Utility.FileSystemEncoding
+import Utility.OsPath
import Annex.DirHashes
#ifdef mingw32_HOST_OS
import Utility.Split
#endif
import Data.Default
-import System.FilePath.Posix
+import qualified System.FilePath.Posix as Posix
import qualified Data.List.NonEmpty as NE
type RsyncUrl = String
| otherwise = u
mkRsyncUrl :: RsyncOpts -> FilePath -> RsyncUrl
-mkRsyncUrl o f = rsyncUrl o </> rsyncEscape o f
+mkRsyncUrl o f = rsyncUrl o Posix.</> rsyncEscape o f
rsyncUrls :: RsyncOpts -> Key -> [RsyncUrl]
rsyncUrls o k = map use (NE.toList dirHashes)
where
- use h = rsyncUrl o </> hash h </> rsyncEscape o (f </> f)
- f = fromRawFilePath (keyFile k)
+ use h = rsyncUrl o Posix.</> hash h Posix.</> rsyncEscape o (f Posix.</> f)
+ f = fromOsPath (keyFile k)
#ifndef mingw32_HOST_OS
- hash h = fromRawFilePath $ h def k
+ hash h = fromOsPath $ h def k
#else
- hash h = replace "\\" "/" $ fromRawFilePath $ h def k
+ hash h = replace "\\" "/" $ fromOsPath $ h def k
#endif
import Annex.Url (getUserAgent, getUrlOptions, withUrlOptions, UrlOptions(..))
import Utility.Env
import Annex.Verify
+import qualified Utility.FileIO as F
type BucketName = String
type BucketObject = String
when (isIA info && not (isChunkKey k)) $
setUrlPresent k (iaPublicUrl info (bucketObject info k))
-storeHelper :: S3Info -> S3Handle -> Maybe Magic -> FilePath -> S3.Object -> MeterUpdate -> Annex (Maybe S3Etag, Maybe S3VersionID)
+storeHelper :: S3Info -> S3Handle -> Maybe Magic -> OsPath -> S3.Object -> MeterUpdate -> Annex (Maybe S3Etag, Maybe S3VersionID)
storeHelper info h magic f object p = liftIO $ case partSize info of
Just partsz | partsz > 0 -> do
- fsz <- getFileSize (toRawFilePath f)
+ fsz <- getFileSize f
if fsz > partsz
then multipartupload fsz partsz
else singlepartupload
-- Send parts of the file, taking care to stream each part
-- w/o buffering in memory, since the parts can be large.
- etags <- bracketIO (openBinaryFile f ReadMode) hClose $ \fh -> do
+ etags <- bracketIO (F.openBinaryFile f ReadMode) hClose $ \fh -> do
let sendparts meter etags partnum = do
pos <- liftIO $ hTell fh
if pos >= fsz
Left failreason -> do
warning (UnquotedString failreason)
giveup "cannot download content"
- Right loc -> retrieveHelper info h loc (fromRawFilePath f) p iv
+ Right loc -> retrieveHelper info h loc f p iv
Left S3HandleNeedCreds ->
getPublicWebUrls' rs info c k >>= \case
Left failreason -> do
warning (UnquotedString failreason)
giveup "cannot download content"
- Right us -> unlessM (withUrlOptions $ downloadUrl False k p iv us (fromRawFilePath f)) $
+ Right us -> unlessM (withUrlOptions $ downloadUrl False k p iv us f) $
giveup "failed to download content"
Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r)
-retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Annex ()
+retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> Annex ()
retrieveHelper info h loc f p iv = retrieveHelper' h f p iv $
case loc of
Left o -> S3.getObject (bucket info) o
Right (S3VersionID o vid) -> (S3.getObject (bucket info) o)
{ S3.goVersionId = Just vid }
-retrieveHelper' :: S3Handle -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> S3.GetObject -> Annex ()
+retrieveHelper' :: S3Handle -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> S3.GetObject -> Annex ()
retrieveHelper' h f p iv req = liftIO $ runResourceT $ do
S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle h req
Url.sinkResponseFile p iv zeroBytesProcessed f WriteMode rsp
where
req = limit $ S3.headObject (bucket info) o
-storeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
+storeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
storeExportS3 hv r rs info magic f k loc p = void $ storeExportS3' hv r rs info magic f k loc p
-storeExportS3' :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex (Maybe S3Etag, Maybe S3VersionID)
+storeExportS3' :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex (Maybe S3Etag, Maybe S3VersionID)
storeExportS3' hv r rs info magic f k loc p = withS3Handle hv $ \case
Right h -> go h
Left pr -> giveupS3HandleProblem pr (uuid r)
setS3VersionID info rs k mvid
return (metag, mvid)
-retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification
+retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification
retrieveExportS3 hv r info k loc f p = verifyKeyContentIncrementally AlwaysVerify k $ \iv ->
withS3Handle hv $ \case
Right h -> retrieveHelper info h (Left (T.pack exportloc)) f p iv
| otherwise =
i : removemostrecent mtime rest
-retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> ExportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)
+retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> ExportLocation -> [ContentIdentifier] -> OsPath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)
retrieveExportWithContentIdentifierS3 hv r rs info loc (cid:_) dest gk p =
case gk of
Right _mkkey -> do
--
-- When the bucket is not versioned, data loss can result.
-- This is why that configuration requires --force to enable.
-storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
+storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
storeExportWithContentIdentifierS3 hv r rs info magic src k loc _overwritablecids p
| versioning info = go
| otherwise = go
giveup "Cannot reuse this bucket."
_ -> void $ liftIO $ runResourceT $ sendS3Handle h mkobject
where
- file = T.pack $ uuidFile c
+ file = T.pack $ fromOsPath $ uuidFile c
uuidb = L.fromChunks [T.encodeUtf8 $ T.pack $ fromUUID u]
mkobject = putObject info file (RequestBodyLBS uuidb)
check (S3.GetObjectMemoryResponse _meta rsp) =
responseStatus rsp == ok200 && responseBody rsp == uuidb
- file = T.pack $ uuidFile c
+ file = T.pack $ fromOsPath $ uuidFile c
uuidb = L.fromChunks [T.encodeUtf8 $ T.pack $ fromUUID u]
-uuidFile :: ParsedRemoteConfig -> FilePath
-uuidFile c = getFilePrefix c ++ "annex-uuid"
+uuidFile :: ParsedRemoteConfig -> OsPath
+uuidFile c = toOsPath (getFilePrefix c) <> literalOsPath "annex-uuid"
tryS3 :: ResourceT IO a -> ResourceT IO (Either S3.S3Error a)
tryS3 a = (Right <$> a) `catch` (pure . Left)
getBucketExportLocation :: ParsedRemoteConfig -> ExportLocation -> BucketObject
getBucketExportLocation c loc =
- getFilePrefix c ++ fromRawFilePath (fromExportLocation loc)
+ getFilePrefix c ++ fromOsPath (fromExportLocation loc)
getBucketImportLocation :: ParsedRemoteConfig -> BucketObject -> Maybe ImportLocation
getBucketImportLocation c obj
-- The uuidFile should not be imported.
- | obj == uuidfile = Nothing
+ | obj == fromOsPath uuidfile = Nothing
-- Only import files that are under the fileprefix, when
-- one is configured.
| prefix `isPrefixOf` obj = Just $ mkImportLocation $
- toRawFilePath $ drop prefixlen obj
+ toOsPath $ drop prefixlen obj
| otherwise = Nothing
where
prefix = getFilePrefix c
{- The TMVar is left empty until tahoe has been verified to be running. -}
data TahoeHandle = TahoeHandle TahoeConfigDir (TMVar ())
-type TahoeConfigDir = FilePath
+type TahoeConfigDir = OsPath
type SharedConvergenceSecret = String
type IntroducerFurl = String
type Capability = String
c <- parsedRemoteConfig remote rc
cst <- remoteCost gc c expensiveRemoteCost
hdl <- liftIO $ TahoeHandle
- <$> maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc)
+ <$> maybe (defaultTahoeConfigDir u)
+ (return . toOsPath)
+ (remoteAnnexTahoe gc)
<*> newEmptyTMVarIO
return $ Just $ Remote
{ uuid = u
, (scsField, Proposed scs)
]
else c
- gitConfigSpecialRemote u c' [("tahoe", configdir)]
+ gitConfigSpecialRemote u c' [("tahoe", fromOsPath configdir)]
return (c', u)
where
missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use."
-store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
+store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()
store rs hdl k _af o _p = sendAnnex k o noop $ \src _sz ->
- parsePut <$> liftIO (readTahoe hdl "put" [File src]) >>= maybe
+ parsePut <$> liftIO (readTahoe hdl "put" [File (fromOsPath src)]) >>= maybe
(giveup "tahoe failed to store content")
(\cap -> storeCapability rs k cap)
-retrieve :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+retrieve :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
retrieve rs hdl k _f d _p _ = do
go =<< getCapability rs k
-- Tahoe verifies the content it retrieves using cryptographically
return Verified
where
go Nothing = giveup "tahoe capability is not known"
- go (Just cap) = unlessM (liftIO $ requestTahoe hdl "get" [Param cap, File d]) $
+ go (Just cap) = unlessM (liftIO $ requestTahoe hdl "get" [Param cap, File (fromOsPath d)]) $
giveup "tahoe failed to reteieve content"
remove :: Maybe SafeDropProof -> Key -> Annex ()
defaultTahoeConfigDir :: UUID -> IO TahoeConfigDir
defaultTahoeConfigDir u = do
h <- myHomeDir
- return $ h </> ".tahoe-git-annex" </> fromUUID u
+ return $ toOsPath h </> literalOsPath ".tahoe-git-annex" </> fromUUID u
tahoeConfigure :: TahoeConfigDir -> IntroducerFurl -> Maybe SharedConvergenceSecret -> IO SharedConvergenceSecret
tahoeConfigure configdir furl mscs = do
createClient :: TahoeConfigDir -> IntroducerFurl -> IO Bool
createClient configdir furl = do
- createDirectoryIfMissing True $
- fromRawFilePath $ parentDir $ toRawFilePath configdir
+ createDirectoryIfMissing True $ parentDir configdir
boolTahoe configdir "create-client"
[ Param "--nickname", Param "git-annex"
, Param "--introducer", Param furl
writeSharedConvergenceSecret :: TahoeConfigDir -> SharedConvergenceSecret -> IO ()
writeSharedConvergenceSecret configdir scs =
- writeFile (convergenceFile configdir) (unlines [scs])
+ writeFile (fromOsPath (convergenceFile configdir))
+ (unlines [scs])
{- The tahoe daemon writes the convergenceFile shortly after it starts
- (it does not need to connect to the network). So, try repeatedly to read
getSharedConvergenceSecret :: TahoeConfigDir -> IO SharedConvergenceSecret
getSharedConvergenceSecret configdir = go (60 :: Int)
where
- f = convergenceFile configdir
+ f = fromOsPath $ convergenceFile configdir
go n
| n == 0 = giveup $ "tahoe did not write " ++ f ++ " after 1 minute. Perhaps the daemon failed to start?"
| otherwise = do
threadDelaySeconds (Seconds 1)
go (n - 1)
-convergenceFile :: TahoeConfigDir -> FilePath
-convergenceFile configdir = configdir </> "private" </> "convergence"
+convergenceFile :: TahoeConfigDir -> OsPath
+convergenceFile configdir =
+ configdir </> literalOsPath "private" </> literalOsPath "convergence"
startTahoeDaemon :: TahoeConfigDir -> IO ()
startTahoeDaemon configdir = void $ boolTahoe configdir "start" []
tahoeParams :: TahoeConfigDir -> String -> [CommandParam] -> [CommandParam]
tahoeParams configdir command params =
- Param "-d" : File configdir : Param command : params
+ Param "-d" : File (fromOsPath configdir) : Param command : params
storeCapability :: RemoteStateHandle -> Key -> Capability -> Annex ()
storeCapability rs k cap = setRemoteState rs k cap
gitConfigSpecialRemote u c [("web", "true")]
return (c, u)
-downloadKey :: UrlIncludeExclude -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
+downloadKey :: UrlIncludeExclude -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
downloadKey urlincludeexclude key _af dest p vc =
go =<< getWebUrls' urlincludeexclude key
where
let b = if isCryptographicallySecure db
then db
else defaultHashBackend
- generateEquivilantKey b (toRawFilePath dest) >>= \case
+ generateEquivilantKey b dest >>= \case
Nothing -> return Nothing
Just ek -> do
unless (ek `elem` eks) $
setEquivilantKey key ek
return (Just Verified)
-uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
+uploadKey :: Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()
uploadKey _ _ _ _ = giveup "upload to web not supported"
dropKey :: UrlIncludeExclude -> Maybe SafeDropProof -> Key -> Annex ()
LegacyChunks _ -> do
-- Not doing incremental verification for chunks.
liftIO $ maybe noop unableIncrementalVerifier iv
- retrieveLegacyChunked (fromRawFilePath d) k p dav
+ retrieveLegacyChunked (fromOsPath d) k p dav
_ -> liftIO $ goDAV dav $
- retrieveHelper (keyLocation k) (fromRawFilePath d) p iv
+ retrieveHelper (keyLocation k) d p iv
-retrieveHelper :: DavLocation -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> DAVT IO ()
+retrieveHelper :: DavLocation -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> DAVT IO ()
retrieveHelper loc d p iv = do
debugDav $ "retrieve " ++ loc
inLocation loc $
existsDAV (keyLocation k)
either giveup return v
-storeExportDav :: DavHandleVar -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
+storeExportDav :: DavHandleVar -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
storeExportDav hdl f k loc p = case exportLocation loc of
Right dest -> withDavHandle hdl $ \h -> runExport h $ \dav -> do
reqbody <- liftIO $ httpBodyStorer f p
storeHelper dav (exportTmpLocation loc k) dest reqbody
Left err -> giveup err
-retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification
+retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification
retrieveExportDav hdl k loc d p = case exportLocation loc of
Right src -> verifyKeyContentIncrementally AlwaysVerify k $ \iv ->
withDavHandle hdl $ \h -> runExport h $ \_dav ->
removeExportDirectoryDav :: DavHandleVar -> ExportDirectory -> Annex ()
removeExportDirectoryDav hdl dir = withDavHandle hdl $ \h -> runExport h $ \_dav -> do
- let d = fromRawFilePath $ fromExportDirectory dir
+ let d = fromOsPath $ fromExportDirectory dir
debugDav $ "delContent " ++ d
inLocation d delContentM
finalizer tmp' dest' = goDAV dav $
finalizeStore dav tmp' (fromJust $ locationParent dest')
- tmp = addTrailingPathSeparator $ keyTmpLocation k
+ tmp = fromOsPath $ addTrailingPathSeparator $ toOsPath $ keyTmpLocation k
dest = keyLocation k
retrieveLegacyChunked :: FilePath -> Key -> MeterUpdate -> DavHandle -> Annex ()
#ifdef mingw32_HOST_OS
import Utility.Split
#endif
-import Utility.FileSystemEncoding
+import Utility.OsPath
-import System.FilePath.Posix -- for manipulating url paths
+import qualified System.FilePath.Posix as UrlPath
import Network.Protocol.HTTP.DAV (inDAVLocation, DAVT)
import Control.Monad.IO.Class (MonadIO)
import Network.URI
{- Runs action with a new location relative to the current location. -}
inLocation :: (MonadIO m) => DavLocation -> DAVT m a -> DAVT m a
-inLocation d = inDAVLocation (</> d')
+inLocation d = inDAVLocation (UrlPath.</> d')
where
d' = escapeURIString isUnescapedInURI d
{- The directory where files(s) for a key are stored. -}
keyDir :: Key -> DavLocation
-keyDir k = addTrailingPathSeparator $ hashdir </> fromRawFilePath (keyFile k)
+keyDir k = UrlPath.addTrailingPathSeparator $
+ hashdir UrlPath.</> fromOsPath (keyFile k)
where
#ifndef mingw32_HOST_OS
- hashdir = fromRawFilePath $ hashDirLower def k
+ hashdir = fromOsPath $ hashDirLower def k
#else
- hashdir = replace "\\" "/" (fromRawFilePath $ hashDirLower def k)
+ hashdir = replace "\\" "/" (fromOsPath $ hashDirLower def k)
#endif
keyLocation :: Key -> DavLocation
-keyLocation k = keyDir k ++ fromRawFilePath (keyFile k)
+keyLocation k = keyDir k ++ fromOsPath (keyFile k)
{- Paths containing # or ? cannot be represented in an url, so fails on
- those. -}
exportLocation :: ExportLocation -> Either String DavLocation
exportLocation l =
- let p = fromRawFilePath $ fromExportLocation l
+ let p = fromOsPath $ fromExportLocation l
in if any (`elem` p) illegalinurl
then Left ("Cannot store file containing '#' or '?' on webdav: " ++ p)
else Right p
{- Where we store temporary data for a key as it's being uploaded. -}
keyTmpLocation :: Key -> DavLocation
-keyTmpLocation = tmpLocation . fromRawFilePath . keyFile
+keyTmpLocation = tmpLocation . fromOsPath . keyFile
{- Where we store temporary data for a file as it's being exported.
-
-}
exportTmpLocation :: ExportLocation -> Key -> DavLocation
exportTmpLocation l k
- | length (splitDirectories p) > 1 = takeDirectory p </> keyTmpLocation k
+ | length (UrlPath.splitDirectories p) > 1 =
+ UrlPath.takeDirectory p UrlPath.</> keyTmpLocation k
| otherwise = keyTmpLocation k
where
- p = fromRawFilePath (fromExportLocation l)
+ p = fromOsPath (fromExportLocation l)
tmpLocation :: FilePath -> DavLocation
tmpLocation f = "git-annex-webdav-tmp-" ++ f
| otherwise = Just parent
where
tops = ["/", "", "."]
- parent = takeDirectory loc
+ parent = UrlPath.takeDirectory loc
locationUrl :: URLString -> DavLocation -> URLString
-locationUrl baseurl loc = baseurl </> loc
+locationUrl baseurl loc = baseurl UrlPath.</> loc
runBool [Param "fetch", Param $ Git.repoDescribe r]
send (DONESYNCING url ok)
-torSocketFile :: Annex.Annex (Maybe FilePath)
+torSocketFile :: Annex.Annex (Maybe OsPath)
torSocketFile = do
u <- getUUID
let ident = fromUUID u
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Test where
import qualified Git.Ref
import qualified Git.LsTree
import qualified Git.FilePath
-import qualified Git.Bundle
import qualified Annex.Locations
#ifndef mingw32_HOST_OS
+import qualified Git.Bundle
import qualified Types.GitConfig
#endif
import qualified Types.TrustLevel
import qualified Utility.CopyFile
import qualified Utility.MoveFile
import qualified Utility.StatelessOpenPGP
+import qualified Utility.OsString as OS
import qualified Types.Remote
#ifndef mingw32_HOST_OS
import qualified Remote.Helper.Encryptable
testDirectoryRemote :: TestTree
testDirectoryRemote = testRemote True "directory" $ \remotename -> do
- createDirectory "remotedir"
+ createDirectory (literalOsPath "remotedir")
git_annex "initremote"
[ remotename
, "type=directory"
runtest cfg populate = whenM Git.Bundle.versionSupported $
intmpclonerepo $ do
let cfg' = ["type=directory", "encryption=none", "directory=dir"] ++ cfg
- createDirectory "dir"
+ createDirectory (literalOsPath "dir")
git_annex "initremote" ("foo":("uuid=" ++ diruuid):cfg') "initremote"
git_annex "get" [] "get failed"
() <- populate
git_annex "get" [annexedfile] "get from origin special remote"
diruuid="89ddefa4-a04c-11ef-87b5-e880882a4f98"
#else
-test_git_remote_annex exporttree =
+test_git_remote_annex _exporttree =
-- git-remote-annex is not currently installed on Windows
return ()
#endif
test_add_moved = intmpclonerepo $ do
git_annex "get" [annexedfile] "get failed"
annexed_present annexedfile
- createDirectory subdir
- Utility.MoveFile.moveFile (toRawFilePath annexedfile) (toRawFilePath subfile)
+ createDirectory (toOsPath subdir)
+ Utility.MoveFile.moveFile (toOsPath annexedfile) subfile
git_annex "add" [subdir] "add of moved annexed file"
git "mv" [sha1annexedfile, sha1annexedfile ++ ".renamed"] "git mv"
git_annex "add" [] "add does not fail on deleted file after move"
where
subdir = "subdir"
- subfile = subdir </> "file"
+ subfile = toOsPath subdir </> literalOsPath "file"
test_readonly_remote :: Assertion
test_readonly_remote =
test_ignore_deleted_files = intmpclonerepo $ do
git_annex "get" [annexedfile] "get"
git_annex_expectoutput "find" [] [annexedfile]
- removeWhenExistsWith R.removeLink (toRawFilePath annexedfile)
+ removeWhenExistsWith removeFile (toOsPath annexedfile)
-- A file that has been deleted, but the deletion not staged,
-- is a special case; make sure git-annex skips these.
git_annex_expectoutput "find" [] []
#endif
test_import :: Assertion
-test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePath "importtest")) $ \importdir -> do
- (toimport1, importf1, imported1) <- mktoimport importdir "import1"
+test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir (literalOsPath "importtest") $ \importdir -> do
+ (toimport1, importf1, imported1) <- mktoimport importdir (literalOsPath "import1")
git_annex "import" [toimport1] "import"
annexed_present_imported imported1
checkdoesnotexist importf1
- (toimport2, importf2, imported2) <- mktoimport importdir "import2"
+ (toimport2, importf2, imported2) <- mktoimport importdir (literalOsPath "import2")
git_annex "import" [toimport2] "import of duplicate"
annexed_present_imported imported2
checkdoesnotexist importf2
- (toimport3, importf3, imported3) <- mktoimport importdir "import3"
+ (toimport3, importf3, imported3) <- mktoimport importdir (literalOsPath "import3")
git_annex "import" ["--skip-duplicates", toimport3]
"import of duplicate with --skip-duplicates"
checkdoesnotexist imported3
checkdoesnotexist imported3
checkdoesnotexist importf3
- (toimport4, importf4, imported4) <- mktoimport importdir "import4"
+ (toimport4, importf4, imported4) <- mktoimport importdir (literalOsPath "import4")
git_annex "import" ["--deduplicate", toimport4] "import --deduplicate"
checkdoesnotexist imported4
checkdoesnotexist importf4
- (toimport5, importf5, imported5) <- mktoimport importdir "import5"
+ (toimport5, importf5, imported5) <- mktoimport importdir (literalOsPath "import5")
git_annex "import" ["--duplicate", toimport5] "import --duplicate"
annexed_present_imported imported5
checkexists importf5
git_annex "drop" ["--force", imported1, imported2, imported5] "drop"
annexed_notpresent_imported imported2
- (toimportdup, importfdup, importeddup) <- mktoimport importdir "importdup"
+ (toimportdup, importfdup, importeddup) <- mktoimport importdir (literalOsPath "importdup")
git_annex_shouldfail "import" ["--clean-duplicates", toimportdup]
"import of missing duplicate with --clean-duplicates not allowed"
checkdoesnotexist importeddup
where
mktoimport importdir subdir = do
createDirectory (importdir </> subdir)
- let importf = subdir </> "f"
- writecontent (importdir </> importf) (content importf)
- return (importdir </> subdir, importdir </> importf, importf)
+ let importf = subdir </> literalOsPath "f"
+ writecontent (fromOsPath (importdir </> importf))
+ (content (fromOsPath importf))
+ return
+ ( fromOsPath (importdir </> subdir)
+ , fromOsPath (importdir </> importf)
+ , fromOsPath importf
+ )
test_reinject :: Assertion
test_reinject = intmpclonerepo $ do
git_annex "get" [annexedfile] "get of file"
git_annex "unlock" [annexedfile] "unlock"
annexeval $ do
- Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile)
+ Just k <- Annex.WorkTree.lookupKey (toOsPath annexedfile)
Database.Keys.removeInodeCaches k
Database.Keys.closeDb
- liftIO . removeWhenExistsWith R.removeLink
+ liftIO . removeWhenExistsWith removeFile
=<< Annex.calcRepo' Annex.Locations.gitAnnexKeysDbIndexCache
writecontent annexedfile "test_lock_force content"
git_annex_shouldfail "lock" [annexedfile] "lock of modified file should not be allowed"
annexed_present annexedfile
git_annex "fix" [annexedfile] "fix of present file"
annexed_present annexedfile
- createDirectory subdir
+ createDirectory (toOsPath subdir)
git "mv" [annexedfile, subdir] "git mv"
git_annex "fix" [newfile] "fix of moved file"
runchecks [checklink, checkunwritable] newfile
where
corrupt f = do
git_annex "get" [f] "get of file"
- Utility.FileMode.allowWrite (toRawFilePath f)
+ Utility.FileMode.allowWrite (toOsPath f)
writecontent f (changedcontent f)
ifM (hasUnlockedFiles <$> getTestMode)
( git_annex "fsck" []"fsck on unlocked file with changed file content"
writecontent "unusedfile" "unusedcontent"
git_annex "add" ["unusedfile"] "add of unusedfile"
unusedfilekey <- getKey backendSHA256E "unusedfile"
- renameFile "unusedfile" "unusedunstagedfile"
+ renameFile
+ (literalOsPath "unusedfile")
+ (literalOsPath "unusedunstagedfile")
git "rm" ["-qf", "unusedfile"] "git rm"
checkunused [] "with unstaged link"
- removeFile "unusedunstagedfile"
+ removeFile (literalOsPath "unusedunstagedfile")
checkunused [unusedfilekey] "with renamed link deleted"
-- unused used to miss symlinks that were deleted or modified
git_annex "add" ["unusedfile"] "add of unusedfile"
git "add" ["unusedfile"] "git add"
checkunused [] "with staged file"
- removeFile "unusedfile"
+ removeFile (literalOsPath "unusedfile")
checkunused [] "with staged deleted file"
-- When an unlocked file is modified, git diff will cause git-annex
{- --include=* should match files in subdirectories too,
- and --exclude=* should exclude them. -}
- createDirectory "dir"
+ createDirectory (literalOsPath "dir")
writecontent "dir/subfile" "subfile"
git_annex "add" ["dir"] "add of subdir"
git_annex_expectoutput "find" ["--include", "*", "--exclude", annexedfile, "--exclude", sha1annexedfile] ["dir/subfile"]
dupfile = annexedfile ++ "2"
dupfile2 = annexedfile ++ "3"
makedup f = do
- Utility.CopyFile.copyFileExternal Utility.CopyFile.CopyAllMetaData annexedfile f
- @? "copying annexed file failed"
+ Utility.CopyFile.copyFileExternal
+ Utility.CopyFile.CopyAllMetaData
+ (toOsPath annexedfile)
+ (toOsPath f)
+ @? "copying annexed file failed"
git "add" [f] "git add"
{- Regression test for union merge bug fixed in
conflictor = "conflictor"
variantprefix = conflictor ++ ".variant"
checkmerge what d = do
- l <- getDirectoryContents d
+ l <- map fromOsPath <$> getDirectoryContents (toOsPath d)
let v = filter (variantprefix `isPrefixOf`) l
length v == 2
@? (what ++ " not exactly 2 variant files in: " ++ show l)
conflictor = "conflictor"
variantprefix = conflictor ++ ".variant"
checkmerge what d = do
- l <- getDirectoryContents d
+ l <- map fromOsPath <$> getDirectoryContents (toOsPath d)
let v = filter (variantprefix `isPrefixOf`) l
length v == 2
@? (what ++ " not exactly 2 variant files in: " ++ show l)
git_annex "sync" ["--no-content"] "sync in r1"
intopdir r2 $ do
disconnectOrigin
- createDirectory conflictor
+ createDirectory (toOsPath conflictor)
writecontent subfile "subfile"
add_annex conflictor "add conflicter"
git_annex "sync" ["--no-content"] "sync in r2"
checkmerge "r1" r1
checkmerge "r2" r2
conflictor = "conflictor"
- subfile = conflictor </> "subfile"
+ subfile = fromOsPath (toOsPath conflictor </> literalOsPath "subfile")
checkmerge what d = do
- doesDirectoryExist (d </> conflictor)
+ doesDirectoryExist (toOsPath d </> toOsPath conflictor)
@? (d ++ " conflictor directory missing")
- l <- getDirectoryContents d
- let v = filter (Annex.VariantFile.variantMarker `isInfixOf`) l
+ l <- map fromOsPath <$> getDirectoryContents (toOsPath d)
+ let v = filter (fromOsPath Annex.VariantFile.variantMarker `isInfixOf`) l
not (null v)
@? (what ++ " conflictor variant file missing in: " ++ show l )
length v == 1
@? (what ++ " too many variant files in: " ++ show v)
intopdir d $ do
git_annex "get" (conflictor:v) ("get in " ++ what)
- git_annex_expectoutput "find" [conflictor] [fromRawFilePath (Git.FilePath.toInternalGitPath (toRawFilePath subfile))]
+ git_annex_expectoutput "find" [conflictor] [fromOsPath (Git.FilePath.toInternalGitPath (toOsPath subfile))]
git_annex_expectoutput "find" v v
{- Check merge conflict resolution when both repos start with an annexed
git_annex "unlock" [conflictor] "unlock conflictor"
writecontent conflictor "newconflictor"
intopdir r1 $
- removeWhenExistsWith R.removeLink (toRawFilePath conflictor)
+ removeWhenExistsWith removeFile (toOsPath conflictor)
let l = if inr1 then [r1, r2, r1] else [r2, r1, r2]
forM_ l $ \r -> intopdir r $
git_annex "sync" ["--no-content"] "sync"
conflictor = "conflictor"
variantprefix = conflictor ++ ".variant"
checkmerge what d = do
- l <- getDirectoryContents d
+ l <- map fromOsPath <$> getDirectoryContents (toOsPath d)
let v = filter (variantprefix `isPrefixOf`) l
not (null v)
@? (what ++ " conflictor variant file missing in: " ++ show l )
nonannexed_content = "nonannexed"
variantprefix = conflictor ++ ".variant"
checkmerge what d = do
- l <- getDirectoryContents d
+ l <- map fromOsPath <$> getDirectoryContents (toOsPath d)
let v = filter (variantprefix `isPrefixOf`) l
not (null v)
@? (what ++ " conflictor variant file missing in: " ++ show l )
length v == 1
@? (what ++ " too many variant files in: " ++ show v)
conflictor `elem` l @? (what ++ " conflictor file missing in: " ++ show l)
- s <- catchMaybeIO (readFile (d </> conflictor))
+ s <- catchMaybeIO $ readFile $ fromOsPath $
+ toOsPath d </> toOsPath conflictor
s == Just nonannexed_content
@? (what ++ " wrong content for nonannexed file: " ++ show s)
symlinktarget = "dummy-target"
variantprefix = conflictor ++ ".variant"
checkmerge what d = do
- l <- getDirectoryContents d
+ l <- map fromOsPath <$> getDirectoryContents (toOsPath d)
let v = filter (variantprefix `isPrefixOf`) l
not (null v)
@? (what ++ " conflictor variant file missing in: " ++ show l )
length v == 1
@? (what ++ " too many variant files in: " ++ show v)
conflictor `elem` l @? (what ++ " conflictor file missing in: " ++ show l)
- s <- catchMaybeIO (R.readSymbolicLink (toRawFilePath (d </> conflictor)))
+ s <- catchMaybeIO $ R.readSymbolicLink $ fromOsPath $
+ toOsPath d </> toOsPath conflictor
s == Just (toRawFilePath symlinktarget)
@? (what ++ " wrong target for nonannexed symlink: " ++ show s)
test_uncommitted_conflict_resolution :: Assertion
test_uncommitted_conflict_resolution = do
check conflictor
- check (conflictor </> "file")
+ check (fromOsPath (toOsPath conflictor </> literalOsPath "file"))
where
check remoteconflictor = withtmpclonerepo $ \r1 ->
withtmpclonerepo $ \r2 -> do
intopdir r1 $ do
disconnectOrigin
- createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath remoteconflictor)))
+ createDirectoryIfMissing True (parentDir (toOsPath remoteconflictor))
writecontent remoteconflictor annexedcontent
add_annex conflictor "add remoteconflicter"
git_annex "sync" ["--no-content"] "sync in r1"
git_annex "sync" ["--no-content"] "sync in r1"
check_is_link conflictor "r1"
intopdir r2 $ do
- createDirectory conflictor
- writecontent (conflictor </> "subfile") "subfile"
+ createDirectory (toOsPath conflictor)
+ writecontent conflictorsubfile "subfile"
git_annex "add" [conflictor] "add conflicter"
git_annex "sync" ["--no-content"] "sync in r2"
- check_is_link (conflictor </> "subfile") "r2"
+ check_is_link conflictorsubfile "r2"
intopdir r3 $ do
writecontent conflictor "conflictor"
git_annex "add" [conflictor] "add conflicter"
git_annex "sync" ["--no-content"] "sync in r1"
- check_is_link (conflictor </> "subfile") "r3"
+ check_is_link conflictorsubfile "r3"
where
conflictor = "conflictor"
+ conflictorsubfile = fromOsPath $
+ toOsPath conflictor </> literalOsPath "subfile"
check_is_link f what = do
- git_annex_expectoutput "find" ["--include=*", f] [fromRawFilePath (Git.FilePath.toInternalGitPath (toRawFilePath f))]
+ git_annex_expectoutput "find" ["--include=*", f] [fromOsPath (Git.FilePath.toInternalGitPath (toOsPath f))]
l <- annexeval $ Annex.inRepo $ Git.LsTree.lsTreeFiles (Git.LsTree.LsTreeLong False) Git.Ref.headRef [f]
all (\i -> Git.Types.toTreeItemType (Git.LsTree.mode i) == Just Git.Types.TreeSymlink) l
@? (what ++ " " ++ f ++ " lost symlink bit after merge: " ++ show l)
conflictor = "conflictor"
variantprefix = conflictor ++ ".variant"
checkmerge what d = intopdir d $ do
- l <- getDirectoryContents "."
+ l <- map fromOsPath <$> getDirectoryContents (literalOsPath ".")
let v = filter (variantprefix `isPrefixOf`) l
length v == 0
@? (what ++ " not exactly 0 variant files in: " ++ show l)
git_annex "sync" ["--no-content"] "sync"
checkmerge what d = intopdir d $ whensupported $ do
git_annex "sync" ["--no-content"] ("sync should not work in " ++ what)
- l <- getDirectoryContents "."
+ l <- map fromOsPath <$> getDirectoryContents (literalOsPath ".")
conflictor `elem` l
@? ("conflictor not present after merge in " ++ what)
-- Currently this fails on FAT, for unknown reasons not to
origbranch <- annexeval origBranch
git_annex "upgrade" [] "upgrade"
git_annex "adjust" ["--unlock", "--force"] "adjust"
- createDirectoryIfMissing True "a/b/c"
+ createDirectoryIfMissing True (literalOsPath "a/b/c")
writecontent "a/b/c/d" "foo"
git_annex "add" ["a/b/c"] "add a/b/c"
git_annex "sync" ["--no-content"] "sync"
- createDirectoryIfMissing True "a/b/x"
+ createDirectoryIfMissing True (literalOsPath "a/b/x")
writecontent "a/b/x/y" "foo"
git_annex "add" ["a/b/x"] "add a/b/x"
git_annex "sync" ["--no-content"] "sync"
git "checkout" [origbranch] "git checkout"
- doesFileExist "a/b/x/y" @? ("a/b/x/y missing from master after adjusted branch sync")
+ doesFileExist (literalOsPath "a/b/x/y")
+ @? ("a/b/x/y missing from master after adjusted branch sync")
test_map :: Assertion
test_map = intmpclonerepo $ do
-- any exit status is accepted; does abnormal exit
git_annex'' (const True) (const True) "uninit" [] Nothing "uninit"
checkregularfile annexedfile
- doesDirectoryExist ".git" @? ".git vanished in uninit"
+ doesDirectoryExist (literalOsPath ".git") @? ".git vanished in uninit"
test_uninit_inbranch :: Assertion
test_uninit_inbranch = intmpclonerepo $ do
test_hook_remote = intmpclonerepo $ do
#ifndef mingw32_HOST_OS
git_annex "initremote" (words "foo type=hook encryption=none hooktype=foo") "initremote"
- createDirectory dir
+ createDirectory (toOsPath dir)
git_config "annex.foo-store-hook" $
"cp $ANNEX_FILE " ++ loc
git_config "annex.foo-retrieve-hook" $
test_directory_remote :: Assertion
test_directory_remote = intmpclonerepo $ do
- createDirectory "dir"
+ createDirectory (literalOsPath "dir")
git_annex "initremote" (words "foo type=directory encryption=none directory=dir") "initremote"
git_annex "get" [annexedfile] "get of file"
annexed_present annexedfile
test_rsync_remote :: Assertion
test_rsync_remote = intmpclonerepo $ do
#ifndef mingw32_HOST_OS
- createDirectory "dir"
+ createDirectory (literalOsPath "dir")
git_annex "initremote" (words "foo type=rsync encryption=none rsyncurl=dir") "initremote"
git_annex "get" [annexedfile] "get of file"
annexed_present annexedfile
test_bup_remote :: Assertion
test_bup_remote = intmpclonerepo $ when BuildInfo.bup $ do
-- bup special remote needs an absolute path
- dir <- fromRawFilePath <$> absPath (toRawFilePath "dir")
+ dir <- absPath (literalOsPath "dir")
createDirectory dir
- git_annex "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) "initremote"
+ git_annex "initremote" (words $ "foo type=bup encryption=none buprepo="++fromOsPath dir) "initremote"
git_annex "get" [annexedfile] "get of file"
annexed_present annexedfile
git_annex "copy" [annexedfile, "--to", "foo"] "copy --to bup remote"
test_borg_remote :: Assertion
test_borg_remote = when BuildInfo.borg $ do
- borgdirparent <- fromRawFilePath <$> (absPath . toRawFilePath =<< tmprepodir)
- let borgdir = borgdirparent </> "borgrepo"
+ borgdirparent <- absPath . toOsPath =<< tmprepodir
+ let borgdir = fromOsPath (borgdirparent </> literalOsPath "borgrepo")
intmpclonerepo $ do
testProcess "borg" ["init", borgdir, "-e", "none"] Nothing (== True) (const True) "borg init"
testProcess "borg" ["create", borgdir++"::backup1", "."] Nothing (== True) (const True) "borg create"
testscheme "pubkey"
where
gpgcmd = Utility.Gpg.mkGpgCmd Nothing
- testscheme scheme = Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePath "gpgtmp")) $ \gpgtmp -> do
+ testscheme scheme = Utility.Tmp.Dir.withTmpDir (literalOsPath "gpgtmp") $ \gpgtmp -> do
-- Use the system temp directory as gpg temp directory because
-- it needs to be able to store the agent socket there,
-- which can be problematic when testing some filesystems.
- absgpgtmp <- fromRawFilePath <$> absPath (toRawFilePath gpgtmp)
+ absgpgtmp <- absPath gpgtmp
res <- testscheme' scheme absgpgtmp
-- gpg may still be running and would prevent
-- removeDirectoryRecursive from succeeding, so
-- force removal of the temp directory.
- liftIO $ removeDirectoryForCleanup gpgtmp
+ liftIO $ removeDirectoryForCleanup (fromOsPath gpgtmp)
return res
testscheme' scheme absgpgtmp = intmpclonerepo $ do
-- Since gpg uses a unix socket, which is limited to a
-- short path, use whichever is shorter of absolute
-- or relative path.
- relgpgtmp <- fromRawFilePath <$> relPathCwdToFile (toRawFilePath absgpgtmp)
- let gpgtmp = if length relgpgtmp < length absgpgtmp
+ relgpgtmp <- relPathCwdToFile absgpgtmp
+ let gpgtmp = if OS.length relgpgtmp < OS.length absgpgtmp
then relgpgtmp
else absgpgtmp
- void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ \environ -> do
- createDirectory "dir"
+ void $ Utility.Gpg.testHarness (fromOsPath gpgtmp) gpgcmd $ \environ -> do
+ createDirectory (literalOsPath "dir")
let initps =
[ "foo"
, "type=directory"
(c,k) <- annexeval $ do
uuid <- Remote.nameToUUID "foo"
rs <- Logs.Remote.readRemoteLog
- Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile)
+ Just k <- Annex.WorkTree.lookupKey (toOsPath annexedfile)
return (fromJust $ M.lookup uuid rs, k)
let key = if scheme `elem` ["hybrid","pubkey"]
then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId]
let encparams = (Types.Remote.ParsedRemoteConfig mempty mempty, dummycfg)
cipher <- Crypto.decryptCipher' gpgcmd (Just environ) encparams cip
files <- filterM doesFileExist $
- map ("dir" </>) $ concatMap (serializeKeys cipher) keys
+ map (literalOsPath "dir" </>) $ concatMap (serializeKeys cipher) keys
return (not $ null files) <&&> allM (checkFile mvariant) files
checkFile mvariant filename =
- Utility.Gpg.checkEncryptionFile gpgcmd (Just environ) filename $
+ Utility.Gpg.checkEncryptionFile gpgcmd (Just environ) (fromOsPath filename) $
if mvariant == Just Types.Crypto.PubKey then ks else Nothing
- serializeKeys cipher = map fromRawFilePath . NE.toList
+ serializeKeys cipher = NE.toList
. Annex.Locations.keyPaths
. Crypto.encryptKey Types.Crypto.HmacSha1 cipher
#else
test_add_subdirs :: Assertion
test_add_subdirs = intmpclonerepo $ do
- createDirectory "dir"
- writecontent ("dir" </> "foo") $ "dir/" ++ content annexedfile
+ createDirectory (literalOsPath "dir")
+ writecontent (fromOsPath (literalOsPath "dir" </> literalOsPath "foo"))
+ ("dir/" ++ content annexedfile)
git_annex "add" ["dir"] "add of subdir"
{- Regression test for Windows bug where symlinks were not
<$> Annex.CatFile.catObject (Git.Types.Ref (encodeBS "HEAD:dir/foo"))
"../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l)
- createDirectory "dir2"
- writecontent ("dir2" </> "foo") $ content annexedfile
- setCurrentDirectory "dir"
- git_annex "add" [".." </> "dir2"] "add of ../subdir"
+ createDirectory (literalOsPath "dir2")
+ writecontent (fromOsPath (literalOsPath "dir2" </> literalOsPath "foo"))
+ (content annexedfile)
+ setCurrentDirectory (literalOsPath "dir")
+ git_annex "add" [fromOsPath (literalOsPath ".." </> literalOsPath "dir2")]
+ "add of ../subdir"
test_addurl :: Assertion
test_addurl = intmpclonerepo $ do
-- file:// only; this test suite should not hit the network
let filecmd c ps = git_annex c ("-cannex.security.allowed-url-schemes=file" : ps)
- f <- fromRawFilePath <$> absPath (toRawFilePath "myurl")
- let url = replace "\\" "/" ("file:///" ++ dropDrive f)
- writecontent f "foo"
+ f <- absPath (literalOsPath "myurl")
+ let url = replace "\\" "/" ("file:///" ++ fromOsPath (dropDrive f))
+ writecontent (fromOsPath f) "foo"
git_annex_shouldfail "addurl" [url] "addurl should not work on file url"
filecmd "addurl" [url] ("addurl on " ++ url)
let dest = "addurlurldest"
filecmd "addurl" ["--file", dest, url] ("addurl on " ++ url ++ " with --file")
- doesFileExist dest @? (dest ++ " missing after addurl --file")
+ doesFileExist (toOsPath dest)
+ @? (dest ++ " missing after addurl --file")
test_export_import :: Assertion
test_export_import = intmpclonerepo $ do
- createDirectory "dir"
+ createDirectory (literalOsPath "dir")
git_annex "initremote" (words "foo type=directory encryption=none directory=dir exporttree=yes importtree=yes") "initremote"
git_annex "get" [] "get of files"
annexed_present annexedfile
git_annex "merge" ["foo/" ++ origbranch] "git annex merge"
annexed_present_imported "import"
- removeWhenExistsWith R.removeLink (toRawFilePath "import")
+ removeWhenExistsWith removeFile (literalOsPath "import")
writecontent "import" (content "newimport1")
git_annex "add" ["import"] "add of import"
commitchanges
-- verify that export refuses to overwrite modified file
writedir "import" (content "newimport2")
- removeWhenExistsWith R.removeLink (toRawFilePath "import")
+ removeWhenExistsWith removeFile (literalOsPath "import")
writecontent "import" (content "newimport3")
git_annex "add" ["import"] "add of import"
commitchanges
-- resolving import conflict
git_annex "import" [origbranch, "--from", "foo"] "import from dir"
git_shouldfail "merge" ["foo/master", "-mmerge"] "git merge of conflict should exit nonzero"
- removeWhenExistsWith R.removeLink (toRawFilePath "import")
+ removeWhenExistsWith removeFile (literalOsPath "import")
writecontent "import" (content "newimport3")
git_annex "add" ["import"] "add of import"
commitchanges
git_annex "export" [origbranch, "--to", "foo"] "export after import conflict"
dircontains "import" (content "newimport3")
where
- dircontains f v =
- ((v==) <$> readFile ("dir" </> f))
- @? ("did not find expected content of " ++ "dir" </> f)
- writedir f = writecontent ("dir" </> f)
+ dircontains f v = do
+ let df = fromOsPath (literalOsPath "dir" </> stringToOsPath f)
+ ((v==) <$> readFile df)
+ @? ("did not find expected content of " ++ df)
+ writedir f = writecontent (fromOsPath (literalOsPath "dir" </> stringToOsPath f))
-- When on an adjusted branch, this updates the master branch
-- to match it, which is necessary since the master branch is going
-- to be exported.
test_export_import_subdir :: Assertion
test_export_import_subdir = intmpclonerepo $ do
- createDirectory "dir"
+ createDirectory (literalOsPath "dir")
git_annex "initremote" (words "foo type=directory encryption=none directory=dir exporttree=yes importtree=yes") "initremote"
git_annex "get" [] "get of files"
annexed_present annexedfile
- createDirectory subdir
+ createDirectory (toOsPath subdir)
git "mv" [annexedfile, subannexedfile] "git mv"
git "commit" ["-m", "moved"] "git commit"
testimport
testexport
where
- dircontains f v =
- ((v==) <$> readFile ("dir" </> f))
- @? ("did not find expected content of " ++ "dir" </> f)
+ dircontains f v = do
+ let df = fromOsPath (literalOsPath "dir" </> toOsPath f)
+ ((v==) <$> readFile df)
+ @? ("did not find expected content of " ++ df)
subdir = "subdir"
- subannexedfile = "subdir" </> annexedfile
+ subannexedfile = fromOsPath $
+ literalOsPath "subdir" </> toOsPath annexedfile
testexport = do
origbranch <- annexeval origBranch
import qualified Utility.Metered
import qualified Utility.HumanTime
import qualified Command.Uninit
+import qualified Utility.OsString as OS
-- Run a process. The output and stderr is captured, and is only
-- displayed if the process does not return the expected value.
let params' = if debug
then "--debug":params
else params
- testProcess pp (command:params') environ expectedret expectedtranscript faildesc
+ testProcess (fromOsPath pp) (command:params') environ
+ expectedret expectedtranscript faildesc
{- Runs git-annex and returns its standard output. -}
git_annex_output :: String -> [String] -> IO String
git_annex_output command params = do
pp <- Annex.Path.programPath
- Utility.Process.readProcess pp (command:params)
+ Utility.Process.readProcess (fromOsPath pp) (command:params)
git_annex_expectoutput :: String -> [String] -> [String] -> Assertion
git_annex_expectoutput command params expected = do
let v = Git.Types.ConfigValue (toRawFilePath "/dev/null")
origindir <- absPath . Git.Types.fromConfigValue
=<< annexeval (Config.getConfig k v)
- let originurl = "localhost:" ++ fromRawFilePath origindir
+ let originurl = "localhost:" ++ fromOsPath origindir
git "config" [config, originurl] "git config failed"
a
where
checkRepo :: Types.Annex a -> FilePath -> IO a
checkRepo getval d = do
- s <- Annex.new =<< Git.Construct.fromPath (toRawFilePath d)
+ s <- Annex.new =<< Git.Construct.fromPath (toOsPath d)
Annex.eval s $
getval `finally` Annex.Action.stopCoProcesses
-- any type of error and change back to currdir before
-- rethrowing.
r <- bracket_
- (setCurrentDirectory path)
+ (setCurrentDirectory (toOsPath path))
(setCurrentDirectory currdir)
(tryNonAsync a)
case r of
ensuredir :: FilePath -> IO ()
ensuredir d = do
- e <- doesDirectoryExist d
+ let d' = toOsPath d
+ e <- doesDirectoryExist d'
unless e $
- createDirectory d
+ createDirectory d'
{- This is the only place in the test suite that can use setEnv.
- Using it elsewhere can conflict with tasty's use of getEnv, which can
- happen concurrently with a test case running, and would be a problem
- since setEnv is not thread safe. This is run before tasty. -}
setTestEnv :: IO a -> IO a
-setTestEnv a = Utility.Tmp.Dir.withTmpDir (toOsPath "testhome") $ \tmphome -> do
- tmphomeabs <- fromRawFilePath <$> absPath (toRawFilePath tmphome)
+setTestEnv a = Utility.Tmp.Dir.withTmpDir (literalOsPath "testhome") $ \tmphome -> do
+ tmphomeabs <- fromOsPath <$> absPath tmphome
{- Prevent global git configs from affecting the test suite. -}
Utility.Env.Set.setEnv "HOME" tmphomeabs True
Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True
-- Ensure that the same git-annex binary that is running
-- git-annex test is at the front of the PATH.
- p <- Utility.Env.getEnvDefault "PATH" ""
pp <- Annex.Path.programPath
- Utility.Env.Set.setEnv "PATH" (takeDirectory pp ++ [searchPathSeparator] ++ p) True
+ p <- Utility.Env.getEnvDefault "PATH" ""
+ let p' = fromOsPath $
+ takeDirectory pp <> OS.singleton searchPathSeparator <> toOsPath p
+ Utility.Env.Set.setEnv "PATH" p' True
-- Avoid git complaining if it cannot determine the user's
-- email address, or exploding if it doesn't know the user's name.
-- Record top directory.
currdir <- getCurrentDirectory
- Utility.Env.Set.setEnv "TOPDIR" currdir True
+ Utility.Env.Set.setEnv "TOPDIR" (fromOsPath currdir) True
a
removeDirectoryForCleanup :: FilePath -> IO ()
-removeDirectoryForCleanup = removePathForcibly
+removeDirectoryForCleanup = removePathForcibly . toOsPath
cleanup :: FilePath -> IO ()
-cleanup dir = whenM (doesDirectoryExist dir) $ do
- Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath dir)
+cleanup dir = whenM (doesDirectoryExist (toOsPath dir)) $ do
+ Command.Uninit.prepareRemoveAnnexDir' (toOsPath dir)
-- This can fail if files in the directory are still open by a
-- subprocess.
void $ tryIO $ removeDirectoryForCleanup dir
finalCleanup :: IO ()
-finalCleanup = whenM (doesDirectoryExist tmpdir) $ do
- Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath tmpdir)
+finalCleanup = whenM (doesDirectoryExist (toOsPath tmpdir)) $ do
+ Command.Uninit.prepareRemoveAnnexDir' (toOsPath tmpdir)
catchIO (removeDirectoryForCleanup tmpdir) $ \e -> do
print e
putStrLn "sleeping 10 seconds and will retry directory cleanup"
Utility.ThreadScheduler.threadDelaySeconds $
Utility.ThreadScheduler.Seconds 10
- whenM (doesDirectoryExist tmpdir) $
+ whenM (doesDirectoryExist (toOsPath tmpdir)) $
removeDirectoryForCleanup tmpdir
checklink :: FilePath -> Assertion
checklink f = ifM (annexeval Config.crippledFileSystem)
- ( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget (toRawFilePath f)))
+ ( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget (toOsPath f)))
@? f ++ " is not a (crippled) symlink"
, do
s <- R.getSymbolicLinkStatus (toRawFilePath f)
checklocationlog :: FilePath -> Bool -> Assertion
checklocationlog f expected = do
thisuuid <- annexeval Annex.UUID.getUUID
- r <- annexeval $ Annex.WorkTree.lookupKey (toRawFilePath f)
+ r <- annexeval $ Annex.WorkTree.lookupKey (toOsPath f)
case r of
Just k -> do
uuids <- annexeval $ Remote.keyLocations k
checkbackend :: FilePath -> Types.Backend -> Assertion
checkbackend file expected = do
- b <- annexeval $ maybe (return Nothing) (Backend.getBackend file)
- =<< Annex.WorkTree.lookupKey (toRawFilePath file)
+ let file' = toOsPath file
+ b <- annexeval $ maybe (return Nothing) (Backend.getBackend file')
+ =<< Annex.WorkTree.lookupKey file'
assertEqual ("backend for " ++ file) (Just expected) b
checkispointerfile :: FilePath -> Assertion
-checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile (toRawFilePath f)) $
+checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile (toOsPath f)) $
assertFailure $ f ++ " is not a pointer file"
inlocationlog :: FilePath -> Assertion
unannexed_in_git :: FilePath -> Assertion
unannexed_in_git f = do
unannexed f
- r <- annexeval $ Annex.WorkTree.lookupKey (toRawFilePath f)
+ r <- annexeval $ Annex.WorkTree.lookupKey (toOsPath f)
case r of
Just _k -> assertFailure $ f ++ " is annexed in git"
Nothing -> return ()
where
go n = do
let d = "main" ++ show n
- ifM (doesDirectoryExist d)
+ ifM (doesDirectoryExist (toOsPath d))
( go $ n + 1
, do
- createDirectory d
+ createDirectory (toOsPath d)
return d
)
where
go n = do
let d = "tmprepo" ++ show n
- ifM (doesDirectoryExist d)
+ ifM (doesDirectoryExist (toOsPath d))
( go $ n + 1
, return d
)
writecontent f c = go (10000000 :: Integer)
where
go ticsleft = do
- oldmtime <- catchMaybeIO $ getModificationTime f
+ oldmtime <- catchMaybeIO $ getModificationTime (toOsPath f)
writeFile f c
- newmtime <- getModificationTime f
+ newmtime <- getModificationTime (toOsPath f)
if Just newmtime == oldmtime
then do
threadDelay 100000
Nothing -> error "internal"
where
ks = Types.KeySource.KeySource
- { Types.KeySource.keyFilename = toRawFilePath f
- , Types.KeySource.contentLocation = toRawFilePath f
+ { Types.KeySource.keyFilename = toOsPath f
+ , Types.KeySource.contentLocation = toOsPath f
, Types.KeySource.inodeCache = Nothing
}
go Nothing = summarizeresults $ withConcurrentOutput $ do
ensuredir tmpdir
crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem'
- (toRawFilePath tmpdir)
+ (toOsPath tmpdir)
Nothing Nothing False
adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported
let ts = mkts numparts crippledfilesystem adjustedbranchok opts
mapM_ (hPutStrLn stderr) warnings
environ <- Utility.Env.getEnvironment
args <- getArgs
- pp <- Annex.Path.programPath
+ pp <- fromOsPath <$> Annex.Path.programPath
termcolor <- hSupportsANSIColor stdout
let ps = if useColor (lookupOption tastyopts) termcolor
then "--color=always":args
else "--color=never":args
let runone n = do
- let subdir = tmpdir </> show n
+ let subdir = fromOsPath $ toOsPath tmpdir </> toOsPath (show n)
ensuredir subdir
let p = (proc pp ps)
{ env = Just ((subenv, show (n, crippledfilesystem, adjustedbranchok)):environ)
import Types.FileMatcher
import Git.FilePath
import Git.Quote (StringContainingQuotedPath(..))
-import Utility.FileSystemEncoding
+import Utility.OsPath
data ActionItem
= ActionItemAssociatedFile AssociatedFile Key
| ActionItemKey Key
| ActionItemBranchFilePath BranchFilePath Key
| ActionItemFailedTransfer Transfer TransferInfo
- | ActionItemTreeFile RawFilePath
+ | ActionItemTreeFile OsPath
| ActionItemUUID UUID StringContainingQuotedPath
-- ^ UUID with a description or name of the repository
| ActionItemOther (Maybe StringContainingQuotedPath)
instance MkActionItem (Key, AssociatedFile) where
mkActionItem = uncurry $ flip ActionItemAssociatedFile
-instance MkActionItem (Key, RawFilePath) where
+instance MkActionItem (Key, OsPath) where
mkActionItem (key, file) = ActionItemAssociatedFile (AssociatedFile (Just file)) key
-instance MkActionItem (RawFilePath, Key) where
+instance MkActionItem (OsPath, Key) where
mkActionItem (file, key) = mkActionItem (key, file)
instance MkActionItem Key where
actionItemKey (ActionItemOther _) = Nothing
actionItemKey (OnlyActionOn _ ai) = actionItemKey ai
-actionItemFile :: ActionItem -> Maybe RawFilePath
+actionItemFile :: ActionItem -> Maybe OsPath
actionItemFile (ActionItemAssociatedFile (AssociatedFile af) _) = af
actionItemFile (ActionItemTreeFile f) = Just f
actionItemFile (ActionItemUUID _ _) = Nothing
import Types.Key
import Types.KeySource
import Utility.Metered
+import Utility.OsPath
import Utility.FileSystemEncoding
import Utility.Hash (IncrementalVerifier)
, genKey :: Maybe (KeySource -> MeterUpdate -> a Key)
-- Verifies the content of a key, stored in a file, using a hash.
-- This does not need to be cryptographically secure.
- , verifyKeyContent :: Maybe (Key -> RawFilePath -> a Bool)
+ , verifyKeyContent :: Maybe (Key -> OsPath -> a Bool)
-- Incrementally verifies the content of a key, using the same
-- hash as verifyKeyContent, but with the content provided
-- incrementally a piece at a time, until finalized.
, unhandledTransitions :: [TransitionCalculator]
-- ^ when the branch was not able to be updated due to permissions,
-- this is transitions that need to be applied when making queries.
- , cachedFileContents :: [(RawFilePath, L.ByteString)]
+ , cachedFileContents :: [(OsPath, L.ByteString)]
-- ^ contents of a few files recently read from the branch
, needInteractiveAccess :: Bool
-- ^ do new changes written to the journal or branch by another
-- process need to be noticed while the current process is running?
-- (This makes the journal always be read, and avoids using the
-- cache.)
- , alternateJournal :: Maybe RawFilePath
+ , alternateJournal :: Maybe OsPath
-- ^ use this directory for all journals, rather than the
-- gitAnnexJournalDir and gitAnnexPrivateJournalDir.
}
module Types.Direction where
-import qualified Data.ByteString as B
+import Data.ByteString.Short
data Direction = Upload | Download
deriving (Eq, Ord, Show, Read)
-formatDirection :: Direction -> B.ByteString
+formatDirection :: Direction -> ShortByteString
formatDirection Upload = "upload"
formatDirection Download = "download"
-parseDirection :: B.ByteString -> Maybe Direction
+parseDirection :: ShortByteString -> Maybe Direction
parseDirection "upload" = Just Upload
parseDirection "download" = Just Download
parseDirection _ = Nothing
{- git-annex export types
-
- - Copyright 2017-2021 Joey Hess <id@joeyh.name>
+ - Copyright 2017-2025 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE CPP #-}
module Types.Export (
ExportLocation,
import Git.FilePath
import Utility.Split
-import Utility.FileSystemEncoding
+import Utility.OsPath
-import qualified Data.ByteString.Short as S
-import qualified System.FilePath.Posix as Posix
import GHC.Generics
import Control.DeepSeq
+#ifdef WITH_OSPATH
+import qualified System.OsPath.Posix as Posix
+import System.OsString.Internal.Types
+#else
+import qualified System.FilePath.Posix as Posix
+import Utility.FileSystemEncoding
+#endif
-- A location such as a path on a remote, that a key can be exported to.
-- The path is relative to the top of the remote, and uses unix-style
-- path separators.
--
--- This uses a ShortByteString to avoid problems with ByteString getting
--- PINNED in memory which caused memory fragmentation and excessive memory
--- use.
-newtype ExportLocation = ExportLocation S.ShortByteString
+-- This must be a ShortByteString (which OsPath is) in order to to avoid
+-- problems with ByteString getting PINNED in memory which caused memory
+-- fragmentation and excessive memory use.
+newtype ExportLocation = ExportLocation OsPath
deriving (Show, Eq, Generic, Ord)
instance NFData ExportLocation
-mkExportLocation :: RawFilePath -> ExportLocation
-mkExportLocation = ExportLocation . S.toShort . toInternalGitPath
+mkExportLocation :: OsPath -> ExportLocation
+mkExportLocation = ExportLocation . toInternalGitPath
-fromExportLocation :: ExportLocation -> RawFilePath
-fromExportLocation (ExportLocation f) = S.fromShort f
+fromExportLocation :: ExportLocation -> OsPath
+fromExportLocation (ExportLocation f) = f
-newtype ExportDirectory = ExportDirectory RawFilePath
+newtype ExportDirectory = ExportDirectory OsPath
deriving (Show, Eq)
-mkExportDirectory :: RawFilePath -> ExportDirectory
+mkExportDirectory :: OsPath -> ExportDirectory
mkExportDirectory = ExportDirectory . toInternalGitPath
-fromExportDirectory :: ExportDirectory -> RawFilePath
+fromExportDirectory :: ExportDirectory -> OsPath
fromExportDirectory (ExportDirectory f) = f
-- | All subdirectories down to the ExportLocation, with the deepest ones
-- last. Does not include the top of the export.
exportDirectories :: ExportLocation -> [ExportDirectory]
exportDirectories (ExportLocation f) =
- map (ExportDirectory . encodeBS . Posix.joinPath . reverse) (subs [] dirs)
+ map (ExportDirectory . fromposixpath . Posix.joinPath . reverse)
+ (subs [] dirs)
where
subs _ [] = []
subs ps (d:ds) = (d:ps) : subs (d:ps) ds
+#ifdef WITH_OSPATH
dirs = map Posix.dropTrailingPathSeparator $
- dropFromEnd 1 $ Posix.splitPath $ decodeBS $ S.fromShort f
+ dropFromEnd 1 $ Posix.splitPath $ PosixString $ fromOsPath f
+
+ fromposixpath = toOsPath . getPosixString
+#else
+ dirs = map Posix.dropTrailingPathSeparator $
+ dropFromEnd 1 $ Posix.splitPath $ fromOsPath f
+
+ fromposixpath = encodeBS
+#endif
import Types.RepoSize (LiveUpdate)
import Utility.Matcher (Matcher, Token, MatchDesc)
import Utility.FileSize
-import Utility.FileSystemEncoding
+import Utility.OsPath
import Control.Monad.IO.Class
import qualified Data.Map as M
| MatchingUserInfo UserProvidedInfo
data FileInfo = FileInfo
- { contentFile :: RawFilePath
+ { contentFile :: OsPath
-- ^ path to a file containing the content, for operations
-- that examine it
- , matchFile :: RawFilePath
+ , matchFile :: OsPath
-- ^ filepath to match on; may be relative to top of repo or cwd,
-- depending on how globs in preferred content expressions
-- are intended to be matched
}
data ProvidedInfo = ProvidedInfo
- { providedFilePath :: Maybe RawFilePath
+ { providedFilePath :: Maybe OsPath
-- ^ filepath to match on, should not be accessed from disk.
, providedKey :: Maybe Key
, providedFileSize :: Maybe FileSize
, providedLinkType :: Maybe LinkType
}
-keyMatchInfoWithoutContent :: Key -> RawFilePath -> MatchInfo
+keyMatchInfoWithoutContent :: Key -> OsPath -> MatchInfo
keyMatchInfoWithoutContent key file = MatchingInfo $ ProvidedInfo
{ providedFilePath = Just file
, providedKey = Just key
-- This is used when testing a matcher, with values to match against
-- provided by the user.
data UserProvidedInfo = UserProvidedInfo
- { userProvidedFilePath :: UserInfo FilePath
+ { userProvidedFilePath :: UserInfo OsPath
, userProvidedKey :: UserInfo Key
, userProvidedFileSize :: UserInfo FileSize
, userProvidedMimeType :: UserInfo MimeType
, annexVerify :: Bool
, annexPidLock :: Bool
, annexPidLockTimeout :: Seconds
- , annexDbDir :: Maybe RawFilePath
+ , annexDbDir :: Maybe OsPath
, annexAddUnlocked :: GlobalConfigurable (Maybe String)
, annexSecureHashesOnly :: Bool
, annexRetry :: Maybe Integer
, annexPidLock = getbool (annexConfig "pidlock") False
, annexPidLockTimeout = Seconds $ fromMaybe 300 $
getmayberead (annexConfig "pidlocktimeout")
- , annexDbDir = (\d -> toRawFilePath d P.</> fromUUID hereuuid)
+ , annexDbDir = (\d -> toOsPath (toRawFilePath d P.</> fromUUID hereuuid))
<$> getmaybe (annexConfig "dbdir")
, annexAddUnlocked = configurable Nothing $
fmap Just $ getmaybe (annexConfig "addunlocked")
-}
{-# LANGUAGE DeriveGeneric, DeriveFunctor #-}
+{-# LANGUAGE CPP #-}
module Types.Import where
import Data.Char
import Control.DeepSeq
import GHC.Generics
+#ifdef WITH_OSPATH
+import qualified System.OsPath.Posix as Posix
+import System.OsString.Internal.Types
+#else
import qualified System.FilePath.Posix.ByteString as Posix
+#endif
import Types.Export
import Utility.QuickCheck
import Utility.FileSystemEncoding
+import Utility.OsPath
{- Location of content on a remote that can be imported.
- This is just an alias to ExportLocation, because both are referring to a
- location on the remote. -}
type ImportLocation = ExportLocation
-mkImportLocation :: RawFilePath -> ImportLocation
+mkImportLocation :: OsPath -> ImportLocation
mkImportLocation = mkExportLocation
-fromImportLocation :: ImportLocation -> RawFilePath
+fromImportLocation :: ImportLocation -> OsPath
fromImportLocation = fromExportLocation
{- An identifier for content stored on a remote that has been imported into
- of the main tree. Nested subtrees are not allowed. -}
data ImportableContentsChunk m info = ImportableContentsChunk
{ importableContentsSubDir :: ImportChunkSubDir
- , importableContentsSubTree :: [(RawFilePath, info)]
+ , importableContentsSubTree :: [(OsPath, info)]
-- ^ locations are relative to importableContentsSubDir
, importableContentsNextChunk :: m (Maybe (ImportableContentsChunk m info))
-- ^ Continuation to get the next chunk.
}
deriving (Functor)
-newtype ImportChunkSubDir = ImportChunkSubDir { importChunkSubDir :: RawFilePath }
+newtype ImportChunkSubDir = ImportChunkSubDir { importChunkSubDir :: OsPath }
importableContentsChunkFullLocation
:: ImportChunkSubDir
- -> RawFilePath
+ -> OsPath
-> ImportLocation
importableContentsChunkFullLocation (ImportChunkSubDir root) loc =
+#ifdef WITH_OSPATH
+ mkImportLocation $ toOsPath $ getPosixString $ Posix.combine
+ (PosixString $ fromOsPath root)
+ (PosixString $ fromOsPath loc)
+#else
mkImportLocation $ Posix.combine root loc
+#endif
parseKeyVariety,
) where
+import Utility.OsPath
+
import qualified Data.ByteString as S
import qualified Data.ByteString.Short as S (ShortByteString, toShort, fromShort)
import qualified Data.ByteString.Char8 as S8
import Data.ByteString.Builder.Extra
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.ByteString.Char8 as A8
-import Utility.FileSystemEncoding
import Data.List
import Data.Char
import System.Posix.Types
splitKeyNameExtension' keyname = S8.span (/= '.') keyname
{- A filename may be associated with a Key. -}
-newtype AssociatedFile = AssociatedFile (Maybe RawFilePath)
- deriving (Show, Read, Eq, Ord)
+newtype AssociatedFile = AssociatedFile (Maybe OsPath)
+ deriving (Show, Eq, Ord)
{- There are several different varieties of keys. -}
data KeyVariety
module Types.KeySource where
import Utility.InodeCache
-import System.FilePath.ByteString (RawFilePath)
+import Utility.OsPath
{- When content is in the process of being ingested into the annex,
- and a Key generated from it, this data type is used.
- files that may be made while they're in the process of being ingested.
-}
data KeySource = KeySource
- { keyFilename :: RawFilePath
- , contentLocation :: RawFilePath
+ { keyFilename :: OsPath
+ , contentLocation :: OsPath
, inodeCache :: Maybe InodeCache
}
deriving (Show)
import Utility.LockPool (LockHandle)
import qualified Data.Map as M
-import System.FilePath.ByteString (RawFilePath)
+import Utility.OsPath
-type LockCache = M.Map RawFilePath LockHandle
+type LockCache = M.Map OsPath LockHandle
import Data.Ord
+import Common
import qualified Git
import Types.Key
import Types.UUID
import Config.Cost
import Utility.Metered
import Git.Types (RemoteName)
-import Utility.SafeCommand
import Utility.Url
import Utility.DataUnits
-- The key should not appear to be present on the remote until
-- all of its contents have been transferred.
-- Throws exception on failure.
- , storeKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> a ()
+ , storeKey :: Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> a ()
-- Retrieves a key's contents to a file.
-- (The MeterUpdate does not need to be used if it writes
-- sequentially to the file.)
-- Throws exception on failure.
- , retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfigA a -> a Verification
+ , retrieveKeyFile :: Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfigA a -> a Verification
{- Will retrieveKeyFile write to the file in order? -}
, retrieveKeyFileInOrder :: a Bool
-- Retrieves a key's contents to a tmp file, if it can be done cheaply.
-- It's ok to create a symlink or hardlink.
-- Throws exception on failure.
- , retrieveKeyFileCheap :: Maybe (Key -> AssociatedFile -> FilePath -> a ())
+ , retrieveKeyFileCheap :: Maybe (Key -> AssociatedFile -> OsPath -> a ())
-- Security policy for reteiving keys from this remote.
, retrievalSecurityPolicy :: RetrievalSecurityPolicy
-- Removes a key's contents (succeeds even the contents are not present)
-- a Remote's configuration from git
, gitconfig :: RemoteGitConfig
-- a Remote can be associated with a specific local filesystem path
- , localpath :: Maybe FilePath
+ , localpath :: Maybe OsPath
-- a Remote can be known to be readonly
, readonly :: Bool
-- a Remote can allow writes but not have a way to delete content
-- The exported file should not appear to be present on the remote
-- until all of its contents have been transferred.
-- Throws exception on failure.
- { storeExport :: FilePath -> Key -> ExportLocation -> MeterUpdate -> a ()
+ { storeExport :: OsPath -> Key -> ExportLocation -> MeterUpdate -> a ()
-- Retrieves exported content to a file.
-- (The MeterUpdate does not need to be used if it writes
-- sequentially to the file.)
-- Throws exception on failure.
- , retrieveExport :: Key -> ExportLocation -> FilePath -> MeterUpdate -> a Verification
+ , retrieveExport :: Key -> ExportLocation -> OsPath -> MeterUpdate -> a Verification
-- Removes an exported file (succeeds if the contents are not present)
-- Can throw exception if unable to access remote, or if remote
-- refuses to remove the content.
:: ExportLocation
-> [ContentIdentifier]
-- file to write content to
- -> FilePath
+ -> OsPath
-- Either the key, or when it's not yet known, a callback
-- that generates a key from the downloaded content.
-> Either Key (a Key)
--
-- Throws exception on failure.
, storeExportWithContentIdentifier
- :: FilePath
+ :: OsPath
-> Key
-> ExportLocation
-- old content that it's safe to overwrite
-- A source of a Key's content.
data ContentSource
- = FileContent FilePath
+ = FileContent OsPath
| ByteContent L.ByteString
isByteContent :: ContentSource -> Bool
-- content to the verifier before running the callback.
-- This should not be done when it retrieves ByteContent.
type Retriever = forall a.
- Key -> MeterUpdate -> RawFilePath -> Maybe IncrementalVerifier
+ Key -> MeterUpdate -> OsPath -> Maybe IncrementalVerifier
-> (ContentSource -> Annex a) -> Annex a
-- Action that removes a Key's content from a remote.
import Utility.PID
import Utility.QuickCheck
import Utility.Url
-import Utility.FileSystemEncoding
+import Utility.OsPath
import Data.Time.Clock.POSIX
import Control.Concurrent
descTransfrerrable :: t -> Maybe String
instance Transferrable AssociatedFile where
- descTransfrerrable (AssociatedFile af) = fromRawFilePath <$> af
+ descTransfrerrable (AssociatedFile af) = fromOsPath <$> af
instance Transferrable URLString where
descTransfrerrable = Just
-- Comes last, so whitespace is ok. But, in case the filename
-- contains eg a newline, escape it. Use C-style encoding.
serialize (TransferAssociatedFile (AssociatedFile (Just f))) =
- decodeBS (encode_c isUtf8Byte f)
+ fromRawFilePath (encode_c isUtf8Byte (fromOsPath f))
serialize (TransferAssociatedFile (AssociatedFile Nothing)) = ""
deserialize "" = Just $ TransferAssociatedFile $
AssociatedFile Nothing
deserialize s = Just $ TransferAssociatedFile $
- AssociatedFile $ Just $ decode_c $ encodeBS s
+ AssociatedFile $ Just $ toOsPath $ decode_c $ toRawFilePath s
module Types.Transitions where
-import Utility.RawFilePath
+import Utility.OsPath
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Builder
= ChangeFile Builder
| PreserveFile
-type TransitionCalculator = RawFilePath -> L.ByteString -> FileTransition
+type TransitionCalculator = OsPath -> L.ByteString -> FileTransition
- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
module Types.UUID where
import qualified Data.ByteString as B
+import qualified Data.ByteString.Short as SB
import qualified Data.Text as T
import qualified Data.Map as M
import qualified Data.UUID as U
import Control.DeepSeq
import qualified Data.Semigroup as Sem
+import Common
import Git.Types (ConfigValue(..))
-import Utility.FileSystemEncoding
import Utility.QuickCheck
import Utility.Aeson
import qualified Utility.SimpleProtocol as Proto
| B.null b = NoUUID
| otherwise = UUID b
+instance FromUUID SB.ShortByteString where
+ fromUUID (UUID u) = SB.toShort u
+ fromUUID NoUUID = SB.empty
+
+instance ToUUID SB.ShortByteString where
+ toUUID b
+ | SB.null b = NoUUID
+ | otherwise = UUID (SB.fromShort b)
+
+#ifdef WITH_OSPATH
+-- OsPath is a ShortByteString internally, so this is the most
+-- efficient conversion.
+instance FromUUID OsPath where
+ fromUUID s = toOsPath (fromUUID s :: SB.ShortByteString)
+
+instance ToUUID OsPath where
+ toUUID s = toUUID (fromOsPath s :: SB.ShortByteString)
+#endif
+
instance FromUUID String where
fromUUID s = decodeBS (fromUUID s)
) where
import Utility.Url
+import Utility.OsPath
data UrlContents
-- An URL contains a file, whose size may be known.
-- There might be a nicer filename to use.
- = UrlContents (Maybe Integer) (Maybe FilePath)
+ = UrlContents (Maybe Integer) (Maybe OsPath)
-- Sometimes an URL points to multiple files, each accessible
-- by their own URL.
- | UrlMulti [(URLString, Maybe Integer, FilePath)]
+ | UrlMulti [(URLString, Maybe Integer, OsPath)]
g <- Annex.gitRepo
p <- liftIO $ absPath $ Git.repoPath g
return $ Just $ unwords
- [ "Repository", fromRawFilePath p
+ [ "Repository", fromOsPath p
, "is at"
, if v `elem` supportedVersions
then "supported"
-- This avoids complicating the upgrade code by needing to handle
-- upgrading a git repo other than the current repo.
upgraderemote = do
- rp <- fromRawFilePath <$> fromRepo Git.repoPath
+ rp <- fromOsPath <$> fromRepo Git.repoPath
ok <- gitAnnexChildProcess "upgrade"
[ Param "--quiet"
, Param "--autoonly"
showAction "v0 to v1"
-- do the reorganisation of the key files
- olddir <- fromRawFilePath <$> fromRepo gitAnnexDir
+ olddir <- fromRepo gitAnnexDir
keys <- getKeysPresent0 olddir
forM_ keys $ \k ->
moveAnnex k (AssociatedFile Nothing)
- (toRawFilePath $ olddir </> keyFile0 k)
+ (olddir </> toOsPath (keyFile0 k))
-- update the symlinks to the key files
-- No longer needed here; V1.upgrade does the same thing
keyFile0 = Upgrade.V1.keyFile1
fileKey0 :: FilePath -> Key
fileKey0 = Upgrade.V1.fileKey1
-lookupKey0 :: FilePath -> Annex (Maybe (Key, Backend))
-lookupKey0 = Upgrade.V1.lookupKey1
-getKeysPresent0 :: FilePath -> Annex [Key]
+getKeysPresent0 :: OsPath -> Annex [Key]
getKeysPresent0 dir = ifM (liftIO $ doesDirectoryExist dir)
- ( liftIO $ map fileKey0
+ ( liftIO $ map (fileKey0 . fromOsPath)
<$> (filterM present =<< getDirectoryContents dir)
, return []
)
where
present d = do
result <- tryIO $
- R.getFileStatus $ toRawFilePath $
- dir ++ "/" ++ takeFileName d
+ R.getFileStatus $ fromOsPath $
+ dir <> literalOsPath "/" <> takeFileName d
case result of
Right s -> return $ isRegularFile s
Left _ -> return False
import Data.ByteString.Builder
import qualified Data.ByteString as S
import qualified Data.ByteString.Short as S (toShort, fromShort)
-import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (isRegularFile)
import Text.Read
forM_ files move
where
move f = do
- let f' = toRawFilePath f
- let k = fileKey1 (fromRawFilePath (P.takeFileName f'))
- let d = parentDir f'
+ let k = fileKey1 (fromOsPath $ takeFileName f)
+ let d = parentDir f
liftIO $ allowWrite d
- liftIO $ allowWrite f'
- _ <- moveAnnex k (AssociatedFile Nothing) f'
- liftIO $ removeDirectory (fromRawFilePath d)
+ liftIO $ allowWrite f
+ _ <- moveAnnex k (AssociatedFile Nothing) f
+ liftIO $ removeDirectory d
updateSymlinks :: Annex ()
updateSymlinks = do
showAction "updating symlinks"
top <- fromRepo Git.repoPath
(files, cleanup) <- inRepo $ LsFiles.inRepo [] [top]
- forM_ files (fixlink . fromRawFilePath)
+ forM_ files fixlink
void $ liftIO cleanup
where
fixlink f = do
case r of
Nothing -> noop
Just (k, _) -> do
- link <- fromRawFilePath
- <$> calcRepo (gitAnnexLink (toRawFilePath f) k)
+ link <- calcRepo (gitAnnexLink f k)
liftIO $ removeFile f
- liftIO $ R.createSymbolicLink (toRawFilePath link) (toRawFilePath f)
- Annex.Queue.addCommand [] "add" [Param "--"] [f]
+ liftIO $ R.createSymbolicLink (fromOsPath link) (fromOsPath f)
+ Annex.Queue.addCommand [] "add" [Param "--"] [(fromOsPath f)]
moveLocationLogs :: Annex ()
moveLocationLogs = do
oldlocationlogs = do
dir <- fromRepo Upgrade.V2.gitStateDir
ifM (liftIO $ doesDirectoryExist dir)
- ( mapMaybe oldlog2key
+ ( mapMaybe (oldlog2key . fromOsPath)
<$> liftIO (getDirectoryContents dir)
, return []
)
move (l, k) = do
dest <- fromRepo (logFile2 k)
dir <- fromRepo Upgrade.V2.gitStateDir
- let f = dir </> l
- createWorkTreeDirectory (parentDir (toRawFilePath dest))
+ let f = dir </> toOsPath l
+ createWorkTreeDirectory (parentDir dest)
-- could just git mv, but this way deals with
-- log files that are not checked into git,
-- as well as merging with already upgraded
old <- liftIO $ readLog1 f
new <- liftIO $ readLog1 dest
liftIO $ writeLog1 dest (old++new)
- Annex.Queue.addCommand [] "add" [Param "--"] [dest]
- Annex.Queue.addCommand [] "add" [Param "--"] [f]
- Annex.Queue.addCommand [] "rm" [Param "--quiet", Param "-f", Param "--"] [f]
+ Annex.Queue.addCommand [] "add" [Param "--"] [fromOsPath dest]
+ Annex.Queue.addCommand [] "add" [Param "--"] [fromOsPath f]
+ Annex.Queue.addCommand [] "rm" [Param "--quiet", Param "-f", Param "--"] [fromOsPath f]
oldlog2key :: FilePath -> Maybe (FilePath, Key)
oldlog2key l
fileKey1 file = readKey1 $
replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file
-writeLog1 :: FilePath -> [LogLine] -> IO ()
-writeLog1 file ls = viaTmp F.writeFile
- (toOsPath (toRawFilePath file))
- (toLazyByteString $ buildLog ls)
+writeLog1 :: OsPath -> [LogLine] -> IO ()
+writeLog1 file ls = viaTmp F.writeFile file (toLazyByteString $ buildLog ls)
-readLog1 :: FilePath -> IO [LogLine]
-readLog1 file = catchDefaultIO [] $
- parseLog <$> F.readFile (toOsPath (toRawFilePath file))
+readLog1 :: OsPath -> IO [LogLine]
+readLog1 file = catchDefaultIO [] $ parseLog <$> F.readFile file
-lookupKey1 :: FilePath -> Annex (Maybe (Key, Backend))
+lookupKey1 :: OsPath -> Annex (Maybe (Key, Backend))
lookupKey1 file = do
tl <- liftIO $ tryIO getsymlink
case tl of
Left _ -> return Nothing
Right l -> makekey l
where
- getsymlink = takeFileName . fromRawFilePath
- <$> R.readSymbolicLink (toRawFilePath file)
+ getsymlink :: IO OsPath
+ getsymlink = takeFileName . toOsPath
+ <$> R.readSymbolicLink (fromOsPath file)
makekey l = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
Nothing -> do
unless (null kname || null bname ||
- not (isLinkToAnnex (toRawFilePath l))) $
+ not (isLinkToAnnex (fromOsPath l))) $
warning (UnquotedString skip)
return Nothing
Just backend -> return $ Just (k, backend)
where
- k = fileKey1 l
+ k = fileKey1 (fromOsPath l)
bname = decodeBS (formatKeyVariety (fromKey keyVariety k))
kname = decodeBS (S.fromShort (fromKey keyName k))
- skip = "skipping " ++ file ++
+ skip = "skipping " ++ fromOsPath file ++
" (unknown backend " ++ bname ++ ")"
-getKeyFilesPresent1 :: Annex [FilePath]
-getKeyFilesPresent1 = getKeyFilesPresent1' . fromRawFilePath
- =<< fromRepo gitAnnexObjectDir
-getKeyFilesPresent1' :: FilePath -> Annex [FilePath]
+getKeyFilesPresent1 :: Annex [OsPath]
+getKeyFilesPresent1 = getKeyFilesPresent1' =<< fromRepo gitAnnexObjectDir
+getKeyFilesPresent1' :: OsPath -> Annex [OsPath]
getKeyFilesPresent1' dir =
ifM (liftIO $ doesDirectoryExist dir)
( do
dirs <- liftIO $ getDirectoryContents dir
- let files = map (\d -> dir ++ "/" ++ d ++ "/" ++ takeFileName d) dirs
+ let files = map (\d -> dir <> literalOsPath "/" <> d <> literalOsPath "/" <> takeFileName d) dirs
liftIO $ filterM present files
, return []
)
where
+ present :: OsPath -> IO Bool
present f = do
- result <- tryIO $ R.getFileStatus (toRawFilePath f)
+ result <- tryIO $ R.getFileStatus (fromOsPath f)
case result of
Right s -> return $ isRegularFile s
Left _ -> return False
-logFile1 :: Git.Repo -> Key -> String
-logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log"
-
-logFile2 :: Key -> Git.Repo -> String
+logFile2 :: Key -> Git.Repo -> OsPath
logFile2 = logFile' (hashDirLower def)
-logFile' :: (Key -> RawFilePath) -> Key -> Git.Repo -> String
+logFile' :: (Key -> OsPath) -> Key -> Git.Repo -> OsPath
logFile' hasher key repo =
- gitStateDir repo ++ fromRawFilePath (hasher key) ++ fromRawFilePath (keyFile key) ++ ".log"
+ gitStateDir repo <> hasher key <> keyFile key <> literalOsPath ".log"
-stateDir :: FilePath
-stateDir = addTrailingPathSeparator ".git-annex"
+stateDir :: OsPath
+stateDir = addTrailingPathSeparator (literalOsPath ".git-annex")
-gitStateDir :: Git.Repo -> FilePath
-gitStateDir repo = addTrailingPathSeparator $
- fromRawFilePath (Git.repoPath repo) </> stateDir
+gitStateDir :: Git.Repo -> OsPath
+gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo </> stateDir
import Logs
import Messages.Progress
import qualified Utility.FileIO as F
+import qualified Utility.OsString as OS
-olddir :: Git.Repo -> FilePath
+olddir :: Git.Repo -> OsPath
olddir g
- | Git.repoIsLocalBare g = ""
- | otherwise = ".git-annex"
+ | Git.repoIsLocalBare g = literalOsPath ""
+ | otherwise = literalOsPath ".git-annex"
{- .git-annex/ moved to a git-annex branch.
-
e <- liftIO $ doesDirectoryExist old
when e $ do
config <- Annex.getGitConfig
- mapM_ (\(k, f) -> inject f $ fromRawFilePath $ locationLogFile config k) =<< locationLogs
+ mapM_ (\(k, f) -> inject f $ locationLogFile config k) =<< locationLogs
mapM_ (\f -> inject f f) =<< logFiles old
saveState False
showProgressDots
when e $ do
- inRepo $ Git.Command.run [Param "rm", Param "-r", Param "-f", Param "-q", File old]
+ inRepo $ Git.Command.run [Param "rm", Param "-r", Param "-f", Param "-q", File (fromOsPath old)]
unless bare $ inRepo gitAttributesUnWrite
showProgressDots
return UpgradeSuccess
-locationLogs :: Annex [(Key, FilePath)]
+locationLogs :: Annex [(Key, OsPath)]
locationLogs = do
config <- Annex.getGitConfig
dir <- fromRepo gitStateDir
liftIO $ do
- levela <- dirContents (toRawFilePath dir)
+ levela <- dirContents dir
levelb <- mapM tryDirContents levela
files <- mapM tryDirContents (concat levelb)
return $ mapMaybe (islogfile config) (concat files)
where
tryDirContents d = catchDefaultIO [] $ dirContents d
- islogfile config f = maybe Nothing (\k -> Just (k, fromRawFilePath f)) $
+ islogfile config f = maybe Nothing (\k -> Just (k, f)) $
locationLogFileKey config f
-inject :: FilePath -> FilePath -> Annex ()
+inject :: OsPath -> OsPath -> Annex ()
inject source dest = do
old <- fromRepo olddir
- new <- liftIO (readFile $ old </> source)
- Annex.Branch.change (Annex.Branch.RegardingUUID []) (toRawFilePath dest) $ \prev ->
+ new <- liftIO (readFile $ fromOsPath $ old </> source)
+ Annex.Branch.change (Annex.Branch.RegardingUUID []) dest $ \prev ->
encodeBL $ unlines $ nub $ lines (decodeBL prev) ++ lines new
-logFiles :: FilePath -> Annex [FilePath]
-logFiles dir = return . filter (".log" `isSuffixOf`)
+logFiles :: OsPath -> Annex [OsPath]
+logFiles dir = return . filter (literalOsPath ".log" `OS.isSuffixOf`)
<=< liftIO $ getDirectoryContents dir
push :: Annex ()
{- Old .gitattributes contents, not needed anymore. -}
attrLines :: [String]
attrLines =
- [ stateDir </> "*.log merge=union"
- , stateDir </> "*/*/*.log merge=union"
+ [ fromOsPath $ stateDir </> literalOsPath "*.log merge=union"
+ , fromOsPath $ stateDir </> literalOsPath "*/*/*.log merge=union"
]
gitAttributesUnWrite :: Git.Repo -> IO ()
gitAttributesUnWrite repo = do
let attributes = Git.attributes repo
- let attributes' = fromRawFilePath attributes
- whenM (doesFileExist attributes') $ do
+ whenM (doesFileExist attributes) $ do
c <- map decodeBS . fileLines'
- <$> F.readFile' (toOsPath attributes)
- liftIO $ viaTmp (writeFile . fromRawFilePath . fromOsPath)
- (toOsPath attributes)
+ <$> F.readFile' attributes
+ liftIO $ viaTmp (writeFile . fromOsPath) attributes
(unlines $ filter (`notElem` attrLines) c)
- Git.Command.run [Param "add", File attributes'] repo
+ Git.Command.run [Param "add", File (fromOsPath attributes)] repo
-stateDir :: FilePath
-stateDir = addTrailingPathSeparator ".git-annex"
+stateDir :: OsPath
+stateDir = addTrailingPathSeparator (literalOsPath ".git-annex")
-gitStateDir :: Git.Repo -> FilePath
-gitStateDir repo = addTrailingPathSeparator $
- fromRawFilePath (Git.repoPath repo) </> stateDir
+gitStateDir :: Git.Repo -> OsPath
+gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo </> stateDir
import Utility.InodeCache
import Utility.DottedVersion
import Annex.AdjustedBranch
-import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
upgrade :: Bool -> Annex UpgradeResult
stagePointerFile f Nothing =<< hashPointerFile k
ifM (isJust <$> getAnnexLinkTarget f)
( writepointer f k
- , fromdirect (fromRawFilePath f) k
+ , fromdirect f k
)
Database.Keys.addAssociatedFile k
=<< inRepo (toTopFilePath f)
fromdirect f k = ifM (Direct.goodContent k f)
( do
- let f' = toRawFilePath f
-- If linkToAnnex fails for some reason, the work tree
-- file still has the content; the annex object file
-- is just not populated with it. Since the work tree
-- file is recorded as an associated file, things will
-- still work that way, it's just not ideal.
- ic <- withTSDelta (liftIO . genInodeCache f')
- void $ Content.linkToAnnex k f' ic
+ ic <- withTSDelta (liftIO . genInodeCache f)
+ void $ Content.linkToAnnex k f ic
, unlessM (Content.inAnnex k) $ do
-- Worktree file was deleted or modified;
-- if there are no other copies of the content
)
writepointer f k = liftIO $ do
- removeWhenExistsWith R.removeLink f
- F.writeFile' (toOsPath f) (formatPointer k)
+ removeWhenExistsWith removeFile f
+ F.writeFile' f (formatPointer k)
{- Remove all direct mode bookkeeping files. -}
removeDirectCruft :: Annex ()
import Annex.Perms
import Utility.InodeCache
import Annex.InodeSentinal
-import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
setIndirect :: Annex ()
Nothing -> inRepo $ Git.Branch.checkout orighead
{- Absolute FilePaths of Files in the tree that are associated with a key. -}
-associatedFiles :: Key -> Annex [FilePath]
+associatedFiles :: Key -> Annex [OsPath]
associatedFiles key = do
files <- associatedFilesRelative key
- top <- fromRawFilePath <$> fromRepo Git.repoPath
+ top <- fromRepo Git.repoPath
return $ map (top </>) files
{- List of files in the tree that are associated with a key, relative to
- the top of the repo. -}
-associatedFilesRelative :: Key -> Annex [FilePath]
+associatedFilesRelative :: Key -> Annex [OsPath]
associatedFilesRelative key = do
mapping <- calcRepo (gitAnnexMapping key)
- liftIO $ catchDefaultIO [] $ F.withFile (toOsPath mapping) ReadMode $ \h ->
+ liftIO $ catchDefaultIO [] $ F.withFile mapping ReadMode $ \h ->
-- Read strictly to ensure the file is closed promptly
- lines <$> hGetContentsStrict h
+ map toOsPath . lines <$> hGetContentsStrict h
{- Removes the list of associated files. -}
removeAssociatedFiles :: Key -> Annex ()
removeAssociatedFiles key = do
mapping <- calcRepo $ gitAnnexMapping key
modifyContentDir mapping $
- liftIO $ removeWhenExistsWith R.removeLink mapping
+ liftIO $ removeWhenExistsWith removeFile mapping
{- Checks if a file in the tree, associated with a key, has not been modified.
-
- expensive checksum, this relies on a cache that contains the file's
- expected mtime and inode.
-}
-goodContent :: Key -> FilePath -> Annex Bool
-goodContent key file =
- sameInodeCache (toRawFilePath file)
- =<< recordedInodeCache key
+goodContent :: Key -> OsPath -> Annex Bool
+goodContent key file = sameInodeCache file =<< recordedInodeCache key
{- Gets the recorded inode cache for a key.
-
recordedInodeCache key = withInodeCacheFile key $ \f ->
liftIO $ catchDefaultIO [] $
mapMaybe (readInodeCache . decodeBS) . fileLines'
- <$> F.readFile' (toOsPath f)
+ <$> F.readFile' f
{- Removes an inode cache. -}
removeInodeCache :: Key -> Annex ()
removeInodeCache key = withInodeCacheFile key $ \f ->
- modifyContentDir f $
- liftIO $ removeWhenExistsWith R.removeLink f
+ modifyContentDir f $ liftIO $ removeWhenExistsWith removeFile f
-withInodeCacheFile :: Key -> (RawFilePath -> Annex a) -> Annex a
+withInodeCacheFile :: Key -> (OsPath -> Annex a) -> Annex a
withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)
{- File that maps from a key to the file(s) in the git repository. -}
-gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO RawFilePath
+gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO OsPath
gitAnnexMapping key r c = do
loc <- gitAnnexLocation key r c
- return $ loc <> ".map"
+ return $ loc <> literalOsPath ".map"
{- File that caches information about a key's content, used to determine
- if a file has changed. -}
-gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO RawFilePath
+gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO OsPath
gitAnnexInodeCache key r c = do
loc <- gitAnnexLocation key r c
- return $ loc <> ".cache"
+ return $ loc <> literalOsPath ".cache"
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
-import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (isSymbolicLink)
upgrade :: Bool -> Annex UpgradeResult
-- The old content identifier database is deleted here, but the
-- new database is not populated. It will be automatically
-- populated from the git-annex branch the next time it is used.
- removeOldDb . fromRawFilePath =<< fromRepo gitAnnexContentIdentifierDbDirOld
- liftIO . removeWhenExistsWith R.removeLink
+ removeOldDb =<< fromRepo gitAnnexContentIdentifierDbDirOld
+ liftIO . removeWhenExistsWith removeFile
=<< fromRepo gitAnnexContentIdentifierLockOld
-- The export databases are deleted here. The new databases
-- will be populated by the next thing that needs them, the same
-- way as they would be in a fresh clone.
- removeOldDb . fromRawFilePath =<< calcRepo' gitAnnexExportDir
+ removeOldDb =<< calcRepo' gitAnnexExportDir
populateKeysDb
- removeOldDb . fromRawFilePath =<< fromRepo gitAnnexKeysDbOld
- liftIO . removeWhenExistsWith R.removeLink
+ removeOldDb =<< fromRepo gitAnnexKeysDbOld
+ liftIO . removeWhenExistsWith removeFile
=<< fromRepo gitAnnexKeysDbIndexCacheOld
- liftIO . removeWhenExistsWith R.removeLink
+ liftIO . removeWhenExistsWith removeFile
=<< fromRepo gitAnnexKeysDbLockOld
updateSmudgeFilter
return UpgradeSuccess
-gitAnnexKeysDbOld :: Git.Repo -> RawFilePath
-gitAnnexKeysDbOld r = gitAnnexDir r P.</> "keys"
+gitAnnexKeysDbOld :: Git.Repo -> OsPath
+gitAnnexKeysDbOld r = gitAnnexDir r </> literalOsPath "keys"
-gitAnnexKeysDbLockOld :: Git.Repo -> RawFilePath
-gitAnnexKeysDbLockOld r = gitAnnexKeysDbOld r <> ".lck"
+gitAnnexKeysDbLockOld :: Git.Repo -> OsPath
+gitAnnexKeysDbLockOld r =
+ gitAnnexKeysDbOld r <> literalOsPath ".lck"
-gitAnnexKeysDbIndexCacheOld :: Git.Repo -> RawFilePath
-gitAnnexKeysDbIndexCacheOld r = gitAnnexKeysDbOld r <> ".cache"
+gitAnnexKeysDbIndexCacheOld :: Git.Repo -> OsPath
+gitAnnexKeysDbIndexCacheOld r =
+ gitAnnexKeysDbOld r <> literalOsPath ".cache"
-gitAnnexContentIdentifierDbDirOld :: Git.Repo -> RawFilePath
-gitAnnexContentIdentifierDbDirOld r = gitAnnexDir r P.</> "cids"
+gitAnnexContentIdentifierDbDirOld :: Git.Repo -> OsPath
+gitAnnexContentIdentifierDbDirOld r =
+ gitAnnexDir r </> literalOsPath "cids"
-gitAnnexContentIdentifierLockOld :: Git.Repo -> RawFilePath
-gitAnnexContentIdentifierLockOld r = gitAnnexContentIdentifierDbDirOld r <> ".lck"
+gitAnnexContentIdentifierLockOld :: Git.Repo -> OsPath
+gitAnnexContentIdentifierLockOld r =
+ gitAnnexContentIdentifierDbDirOld r <> literalOsPath ".lck"
-removeOldDb :: FilePath -> Annex ()
+removeOldDb :: OsPath -> Annex ()
removeOldDb db =
whenM (liftIO $ doesDirectoryExist db) $ do
v <- liftIO $ tryNonAsync $
removePathForcibly db
case v of
- Left ex -> giveup $ "Failed removing old database directory " ++ db ++ " during upgrade (" ++ show ex ++ ") -- delete that and re-run git-annex to finish the upgrade."
+ Left ex -> giveup $ "Failed removing old database directory " ++ fromOsPath db ++ " during upgrade (" ++ show ex ++ ") -- delete that and re-run git-annex to finish the upgrade."
Right () -> return ()
-- Populate the new keys database with associated files and inode caches.
(l, cleanup) <- inRepo $ LsFiles.inodeCaches [top]
forM_ l $ \case
(_f, Nothing) -> giveup "Unable to parse git ls-files --debug output while upgrading git-annex sqlite databases."
- (f, Just ic) -> unlessM (liftIO $ catchBoolIO $ isSymbolicLink <$> R.getSymbolicLinkStatus (toRawFilePath f)) $ do
- catKeyFile (toRawFilePath f) >>= \case
+ (f, Just ic) -> unlessM (liftIO $ catchBoolIO $ isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath f)) $ do
+ catKeyFile f >>= \case
Nothing -> noop
Just k -> do
- topf <- inRepo $ toTopFilePath $ toRawFilePath f
+ topf <- inRepo $ toTopFilePath f
Database.Keys.runWriter AssociatedTable $ \h -> liftIO $
Database.Keys.SQL.addAssociatedFile k topf h
Database.Keys.runWriter ContentTable $ \h -> liftIO $
updateSmudgeFilter = do
lf <- Annex.fromRepo Git.attributesLocal
ls <- liftIO $ map decodeBS . fileLines'
- <$> catchDefaultIO "" (F.readFile' (toOsPath lf))
+ <$> catchDefaultIO "" (F.readFile' lf)
let ls' = removedotfilter ls
when (ls /= ls') $
- liftIO $ writeFile (fromRawFilePath lf) (unlines ls')
+ liftIO $ writeFile (fromOsPath lf) (unlines ls')
where
removedotfilter ("* filter=annex":".* !filter":rest) =
"* filter=annex" : removedotfilter rest
- run for an entire year and so predate the v9 upgrade. -}
assistantrunning = do
pidfile <- fromRepo gitAnnexPidFile
- isJust <$> liftIO (checkDaemon (fromRawFilePath pidfile))
+ isJust <$> liftIO (checkDaemon pidfile)
unsafeupgrade =
[ "Not upgrading from v9 to v10, because there may be git-annex"
-}
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
module Utility.Aeson (
module X,
import Prelude
import Utility.FileSystemEncoding
+#ifdef WITH_OSPATH
+import Utility.OsPath
+#endif
-- | Use this instead of Data.Aeson.encode to make sure that the
-- below String instance is used.
instance ToJSON' S.ByteString where
toJSON' = toJSON . packByteString
+#ifdef WITH_OSPATH
+instance ToJSON' OsPath where
+ toJSON' p = toJSON' (fromOsPath p :: S.ByteString)
+#endif
+
-- | Pack a String to Text, correctly handling the filesystem encoding.
--
-- Use this instead of Data.Text.pack.
{- The cp command is used, because I hate reinventing the wheel,
- and because this allows easy access to features like cp --reflink
- and preserving metadata. -}
-copyFileExternal :: CopyMetaData -> FilePath -> FilePath -> IO Bool
+copyFileExternal :: CopyMetaData -> OsPath -> OsPath -> IO Bool
copyFileExternal meta src dest = do
-- Delete any existing dest file because an unwritable file
-- would prevent cp from working.
void $ tryIO $ removeFile dest
- boolSystem "cp" $ params ++ [File src, File dest]
+ boolSystem "cp" $ params ++ [File (fromOsPath src), File (fromOsPath dest)]
where
params
| BuildInfo.cp_reflink_supported =
-- When CoW is not supported, cp creates the destination
-- file but leaves it empty.
unless ok $
- void $ tryIO $ removeFile dest
+ void $ tryIO $ removeFile $ toOsPath dest
return ok
| otherwise = return False
where
{- Create a hard link if the filesystem allows it, and fall back to copying
- the file. -}
-createLinkOrCopy :: RawFilePath -> RawFilePath -> IO Bool
+createLinkOrCopy :: OsPath -> OsPath -> IO Bool
createLinkOrCopy src dest = go `catchIO` const fallback
where
go = do
- R.createLink src dest
+ R.createLink (fromOsPath src) (fromOsPath dest)
return True
- fallback = copyFileExternal CopyAllMetaData (fromRawFilePath src) (fromRawFilePath dest)
+ fallback = copyFileExternal CopyAllMetaData src dest
- License: BSD-2-clause
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Utility.Daemon (
#else
import System.Win32.Process (terminateProcessById)
import Utility.LockFile
+import qualified Utility.OsString as OS
#endif
#ifndef mingw32_HOST_OS
- Instead, it runs the cmd with provided params, in the background,
- which the caller should arrange to run this again.
-}
-daemonize :: String -> [CommandParam] -> IO Fd -> Maybe FilePath -> Bool -> IO () -> IO ()
+daemonize :: String -> [CommandParam] -> IO Fd -> Maybe OsPath -> Bool -> IO () -> IO ()
daemonize cmd params openlogfd pidfile changedirectory a = do
maybe noop checkalreadyrunning pidfile
getEnv envvar >>= \case
{- To run an action that is normally daemonized in the foreground. -}
#ifndef mingw32_HOST_OS
-foreground :: IO Fd -> Maybe FilePath -> IO () -> IO ()
+foreground :: IO Fd -> Maybe OsPath -> IO () -> IO ()
foreground openlogfd pidfile a = do
#else
-foreground :: Maybe FilePath -> IO () -> IO ()
+foreground :: Maybe OsPath -> IO () -> IO ()
foreground pidfile a = do
#endif
maybe noop lockPidFile pidfile
-
- Writes the pid to the file, fully atomically.
- Fails if the pid file is already locked by another process. -}
-lockPidFile :: FilePath -> IO ()
+lockPidFile :: OsPath -> IO ()
lockPidFile pidfile = do
#ifndef mingw32_HOST_OS
- fd <- openFdWithMode (toRawFilePath pidfile) ReadWrite (Just stdFileMode) defaultFileFlags
+ fd <- openFdWithMode (fromOsPath pidfile) ReadWrite (Just stdFileMode) defaultFileFlags
locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
- fd' <- openFdWithMode (toRawFilePath newfile) ReadWrite (Just stdFileMode) defaultFileFlags
+ fd' <- openFdWithMode (fromOsPath newfile) ReadWrite (Just stdFileMode) defaultFileFlags
{ trunc = True }
locked' <- catchMaybeIO $ setLock fd' (WriteLock, AbsoluteSeek, 0, 0)
case (locked, locked') of
_ -> do
_ <- fdWrite fd' =<< show <$> getPID
closeFd fd
- rename newfile pidfile
+ renameFile newfile pidfile
where
- newfile = pidfile ++ ".new"
+ newfile = pidfile <> literalOsPath ".new"
#else
{- Not atomic on Windows, oh well. -}
unlessM (isNothing <$> checkDaemon pidfile)
alreadyRunning
pid <- getPID
- writeFile pidfile (show pid)
+ writeFile (fromOsPath pidfile) (show pid)
lckfile <- winLockFile pid pidfile
- writeFile (fromRawFilePath lckfile) ""
+ writeFile (fromOsPath lckfile) ""
void $ lockExclusive lckfile
#endif
- is locked by the same process that is listed in the pid file.
-
- If it's running, returns its pid. -}
-checkDaemon :: FilePath -> IO (Maybe PID)
+checkDaemon :: OsPath -> IO (Maybe PID)
#ifndef mingw32_HOST_OS
checkDaemon pidfile = bracket setup cleanup go
where
setup = catchMaybeIO $
- openFdWithMode (toRawFilePath pidfile) ReadOnly (Just stdFileMode) defaultFileFlags
+ openFdWithMode (fromOsPath pidfile) ReadOnly (Just stdFileMode) defaultFileFlags
cleanup (Just fd) = closeFd fd
cleanup Nothing = return ()
go (Just fd) = catchDefaultIO Nothing $ do
locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0)
- p <- readish <$> readFile pidfile
+ p <- readish <$> readFile (fromOsPath pidfile)
return (check locked p)
go Nothing = return Nothing
check (Just (pid, _)) (Just pid')
| pid == pid' = Just pid
| otherwise = giveup $
- "stale pid in " ++ pidfile ++
+ "stale pid in " ++ fromOsPath pidfile ++
" (got " ++ show pid' ++
"; expected " ++ show pid ++ " )"
#else
checkDaemon pidfile = maybe (return Nothing) (check . readish)
- =<< catchMaybeIO (readFile pidfile)
+ =<< catchMaybeIO (readFile (fromOsPath pidfile))
where
check Nothing = return Nothing
check (Just pid) = do
- v <- lockShared =<< winLockFile pid pidfile
+ v <- lockShared =<< winLockFile pid (fromOsPath pidfile)
case v of
Just h -> do
dropLock h
#endif
{- Stops the daemon, safely. -}
-stopDaemon :: FilePath -> IO ()
+stopDaemon :: OsPath -> IO ()
stopDaemon pidfile = go =<< checkDaemon pidfile
where
go Nothing = noop
- when eg, restarting the daemon.
-}
#ifdef mingw32_HOST_OS
-winLockFile :: PID -> FilePath -> IO RawFilePath
+winLockFile :: PID -> OsPath -> IO OsPath
winLockFile pid pidfile = do
cleanstale
- return $ toRawFilePath $ prefix ++ show pid ++ suffix
+ return $ prefix <> toOsPath (show pid) <> suffix
where
- prefix = pidfile ++ "."
- suffix = ".lck"
+ prefix = pidfile <> literalOsPath "."
+ suffix = literalOsPath ".lck"
cleanstale = mapM_ (void . tryIO . removeFile) =<<
- (filter iswinlockfile <$> dirContents (fromRawFilePath (parentDir (toRawFilePath pidfile))))
- iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f
+ (filter iswinlockfile <$> dirContents (parentDir pidfile))
+ iswinlockfile f = suffix `OS.isSuffixOf` f && prefix `OS.isPrefixOf` f
#endif
) where
import Utility.DirWatcher.Types
+import Utility.OsPath
#if WITH_INOTIFY
import qualified Utility.DirWatcher.INotify as INotify
import qualified System.Win32.Notify as Win32Notify
#endif
-type Pruner = FilePath -> Bool
+type Pruner = OsPath -> Bool
canWatch :: Bool
#if (WITH_INOTIFY || WITH_KQUEUE || WITH_FSEVENTS || WITH_WIN32NOTIFY)
- to shutdown later. -}
#if WITH_INOTIFY
type DirWatcherHandle = INotify.INotify
-watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle
+watchDir :: OsPath -> Pruner -> Bool -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle
watchDir dir prune scanevents hooks runstartup = do
i <- INotify.initINotify
runstartup $ INotify.watchDir i dir prune scanevents hooks
#else
#if WITH_KQUEUE
type DirWatcherHandle = ThreadId
-watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO DirWatcherHandle
+watchDir :: OsPath -> Pruner -> Bool -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO DirWatcherHandle
watchDir dir prune _scanevents hooks runstartup = do
kq <- runstartup $ Kqueue.initKqueue dir prune
forkIO $ Kqueue.runHooks kq hooks
#else
#if WITH_FSEVENTS
type DirWatcherHandle = FSEvents.EventStream
-watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO FSEvents.EventStream -> IO FSEvents.EventStream) -> IO DirWatcherHandle
+watchDir :: OsPath -> Pruner -> Bool -> WatchHooks -> (IO FSEvents.EventStream -> IO FSEvents.EventStream) -> IO DirWatcherHandle
watchDir dir prune scanevents hooks runstartup =
runstartup $ FSEvents.watchDir dir prune scanevents hooks
#else
scan d = unless (ignoredPath ignored d) $
-- Do not follow symlinks when scanning.
-- This mirrors the inotify startup scan behavior.
- mapM_ go =<< emptyWhenDoesNotExist (dirContentsRecursiveSkipping (const False) False d)
+ mapM_ (go . fromRawFilePath) =<< emptyWhenDoesNotExist
+ (dirContentsRecursiveSkipping (const False) False (toRawFilePath d))
where
go f
| ignoredPath ignored f = noop
- So this will fail if there are too many subdirectories. The
- errHook is called when this happens.
-}
-watchDir :: INotify -> FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO ()
+watchDir :: INotify -> OsPath -> (OsPath -> Bool) -> Bool -> WatchHooks -> IO ()
watchDir i dir ignored scanevents hooks
| ignored dir = noop
| otherwise = do
lock <- newLock
let handler event = withLock lock (void $ go event)
flip catchNonAsync failedwatch $ do
- void (addWatch i watchevents (toInternalFilePath dir) handler)
+ void (addWatch i watchevents (fromOsPath dir) handler)
`catchIO` failedaddwatch
withLock lock $
- mapM_ scan =<< filter (not . dirCruft . toRawFilePath) <$>
+ mapM_ scan =<< filter (`notElem` dirCruft) <$>
getDirectoryContents dir
where
recurse d = watchDir i d ignored scanevents hooks
runhook addHook f ms
_ -> noop
where
- f = fromInternalFilePath fi
+ f = toOsPath fi
-- Closing a file is assumed to mean it's done being written,
-- so a new add event is sent.
go (Closed { isDirectory = False, maybeFilePath = Just fi }) =
- checkfiletype Files.isRegularFile addHook $
- fromInternalFilePath fi
+ checkfiletype Files.isRegularFile addHook (toOsPath fi)
-- When a file or directory is moved in, scan it to add new
-- stuff.
- go (MovedIn { filePath = fi }) = scan $ fromInternalFilePath fi
+ go (MovedIn { filePath = fi }) = scan (toOsPath fi)
go (MovedOut { isDirectory = isd, filePath = fi })
| isd = runhook delDirHook f Nothing
| otherwise = runhook delHook f Nothing
where
- f = fromInternalFilePath fi
+ f = toOsPath fi
-- Verify that the deleted item really doesn't exist,
-- since there can be spurious deletion events for items
| otherwise = guarded $ runhook delHook f Nothing
where
guarded = unlessM (filetype (const True) f)
- f = fromInternalFilePath fi
+ f = toOsPath fi
go (Modified { isDirectory = isd, maybeFilePath = Just fi })
| isd = noop
- | otherwise = runhook modifyHook (fromInternalFilePath fi) Nothing
+ | otherwise = runhook modifyHook (toOsPath fi) Nothing
go _ = noop
indir f = dir </> f
- getstatus f = catchMaybeIO $ R.getSymbolicLinkStatus $ toRawFilePath $ indir f
+ getstatus f = catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath $ indir f
+
checkfiletype check h f = do
ms <- getstatus f
case ms of
Just s
| check s -> runhook h f ms
_ -> noop
- filetype t f = catchBoolIO $ t <$> R.getSymbolicLinkStatus (toRawFilePath (indir f))
+ filetype t f = catchBoolIO $ t <$> R.getSymbolicLinkStatus (fromOsPath (indir f))
failedaddwatch e
-- Inotify fails when there are too many watches with a
-- disk full error.
| isFullError e =
case errHook hooks of
- Nothing -> giveup $ "failed to add inotify watch on directory " ++ dir ++ " (" ++ show e ++ ")"
+ Nothing -> giveup $ "failed to add inotify watch on directory " ++ fromOsPath dir ++ " (" ++ show e ++ ")"
Just hook -> tooManyWatches hook dir
-- The directory could have been deleted.
| isDoesNotExistError e = return ()
| otherwise = throw e
- failedwatch e = hPutStrLn stderr $ "failed to add watch on directory " ++ dir ++ " (" ++ show e ++ ")"
+ failedwatch e = hPutStrLn stderr $ "failed to add watch on directory " ++ fromOsPath dir ++ " (" ++ show e ++ ")"
-tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO ()
+tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> OsPath -> IO ()
tooManyWatches hook dir = do
sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer)
hook (unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval) Nothing
where
maxwatches = "fs.inotify.max_user_watches"
- basewarning = "Too many directories to watch! (Not watching " ++ dir ++")"
+ basewarning = "Too many directories to watch! (Not watching " ++ fromOsPath dir ++")"
withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"]
withsysctl n = let new = n * 10 in
[ "Increase the limit permanently by running:"
Nothing -> return Nothing
Just s -> return $ parsesysctl s
parsesysctl s = readish =<< lastMaybe (words s)
-
-toInternalFilePath :: FilePath -> RawFilePath
-toInternalFilePath = toRawFilePath
-
-fromInternalFilePath :: RawFilePath -> FilePath
-fromInternalFilePath = fromRawFilePath
type Hook a = Maybe (a -> Maybe FileStatus -> IO ())
data WatchHooks = WatchHooks
- { addHook :: Hook FilePath
- , addSymlinkHook :: Hook FilePath
- , delHook :: Hook FilePath
- , delDirHook :: Hook FilePath
+ { addHook :: Hook OsPath
+ , addSymlinkHook :: Hook OsPath
+ , delHook :: Hook OsPath
+ , delDirHook :: Hook OsPath
, errHook :: Hook String -- error message
- , modifyHook :: Hook FilePath
+ , modifyHook :: Hook OsPath
}
mkWatchHooks :: WatchHooks
runhook h s = maybe noop (\a -> a (filePath evt) s) (h hooks)
scan d = unless (ignoredPath ignored d) $
- mapM_ go =<< emptyWhenDoesNotExist (dirContentsRecursiveSkipping (const False) False d)
+ mapM_ (go . fromRawFilePath) =<< emptyWhenDoesNotExist
+ (dirContentsRecursiveSkipping (const False) False (toRawFilePath d))
where
go f
| ignoredPath ignored f = noop
import System.PosixCompat.Files (isDirectory, isSymbolicLink)
import Control.Applicative
import System.IO.Unsafe (unsafeInterleaveIO)
-import qualified System.FilePath.ByteString as P
import Data.Maybe
import Prelude
import Utility.OsPath
import Utility.Exception
import Utility.Monad
-import Utility.FileSystemEncoding
import qualified Utility.RawFilePath as R
-dirCruft :: R.RawFilePath -> Bool
-dirCruft "." = True
-dirCruft ".." = True
-dirCruft _ = False
+dirCruft :: [OsPath]
+dirCruft = [literalOsPath ".", literalOsPath ".."]
{- Lists the contents of a directory.
- Unlike getDirectoryContents, paths are not relative to the directory. -}
-dirContents :: RawFilePath -> IO [RawFilePath]
-dirContents d =
- map (\p -> d P.</> fromOsPath p)
- . filter (not . dirCruft . fromOsPath)
- <$> getDirectoryContents (toOsPath d)
+dirContents :: OsPath -> IO [OsPath]
+dirContents d = map (d </>) . filter (`notElem` dirCruft)
+ <$> getDirectoryContents d
{- Gets files in a directory, and then its subdirectories, recursively,
- and lazily.
- be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions).
-}
-dirContentsRecursive :: RawFilePath -> IO [RawFilePath]
+dirContentsRecursive :: OsPath -> IO [OsPath]
dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
{- Skips directories whose basenames match the skipdir. -}
-dirContentsRecursiveSkipping :: (RawFilePath -> Bool) -> Bool -> RawFilePath -> IO [RawFilePath]
+dirContentsRecursiveSkipping :: (OsPath -> Bool) -> Bool -> OsPath -> IO [OsPath]
dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
- | skipdir (P.takeFileName topdir) = return []
+ | skipdir (takeFileName topdir) = return []
| otherwise = do
-- Get the contents of the top directory outside of
-- unsafeInterleaveIO, which allows throwing exceptions if
where
go [] = return []
go (dir:dirs)
- | skipdir (P.takeFileName dir) = go dirs
+ | skipdir (takeFileName dir) = go dirs
| otherwise = unsafeInterleaveIO $ do
(files, dirs') <- collect [] []
=<< catchDefaultIO [] (dirContents dir)
files' <- go (dirs' ++ dirs)
return (files ++ files')
- collect :: [RawFilePath] -> [RawFilePath] -> [RawFilePath] -> IO ([RawFilePath], [RawFilePath])
+ collect :: [OsPath] -> [OsPath] -> [OsPath] -> IO ([OsPath], [OsPath])
collect files dirs' [] = return (reverse files, reverse dirs')
collect files dirs' (entry:entries)
- | dirCruft entry = collect files dirs' entries
+ | entry `elem` dirCruft = collect files dirs' entries
| otherwise = do
let skip = collect (entry:files) dirs' entries
let recurse = collect files (entry:dirs') entries
- ms <- catchMaybeIO $ R.getSymbolicLinkStatus entry
+ ms <- catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath entry)
case ms of
(Just s)
| isDirectory s -> recurse
| isSymbolicLink s && followsubdirsymlinks ->
- ifM (doesDirectoryExist (toOsPath entry))
+ ifM (doesDirectoryExist entry)
( recurse
, skip
)
- be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions).
-}
-dirTreeRecursiveSkipping :: (RawFilePath -> Bool) -> RawFilePath -> IO [RawFilePath]
+dirTreeRecursiveSkipping :: (OsPath -> Bool) -> OsPath -> IO [OsPath]
dirTreeRecursiveSkipping skipdir topdir
- | skipdir (P.takeFileName topdir) = return []
+ | skipdir (takeFileName topdir) = return []
| otherwise = do
subdirs <- filterM isdir =<< dirContents topdir
go [] subdirs
where
go c [] = return c
go c (dir:dirs)
- | skipdir (P.takeFileName dir) = go c dirs
+ | skipdir (takeFileName dir) = go c dirs
| otherwise = unsafeInterleaveIO $ do
subdirs <- go []
=<< filterM isdir
=<< catchDefaultIO [] (dirContents dir)
go (subdirs++dir:c) dirs
- isdir p = isDirectory <$> R.getSymbolicLinkStatus p
+ isdir p = isDirectory <$> R.getSymbolicLinkStatus (fromOsPath p)
{- When the action fails due to the directory not existing, returns []. -}
emptyWhenDoesNotExist :: IO [a] -> IO [a]
import Control.Monad.IfElse
import System.IO.Error
import Data.Maybe
-import qualified System.FilePath.ByteString as P
import Prelude
import Utility.SystemDirectory
import Utility.Path.AbsRel
import Utility.Exception
-import Utility.FileSystemEncoding
-import qualified Utility.RawFilePath as R
+import Utility.OsPath
import Utility.PartialPrelude
{- Like createDirectoryIfMissing True, but it will only create
- Note that, the second FilePath, if relative, is relative to the current
- working directory.
-}
-createDirectoryUnder :: [RawFilePath] -> RawFilePath -> IO ()
+createDirectoryUnder :: [OsPath] -> OsPath -> IO ()
createDirectoryUnder topdirs dir =
- createDirectoryUnder' topdirs dir R.createDirectory
+ createDirectoryUnder' topdirs dir createDirectory
createDirectoryUnder'
:: (MonadIO m, MonadCatch m)
- => [RawFilePath]
- -> RawFilePath
- -> (RawFilePath -> m ())
+ => [OsPath]
+ -> OsPath
+ -> (OsPath -> m ())
-> m ()
createDirectoryUnder' topdirs dir0 mkdir = do
relps <- liftIO $ forM topdirs $ \topdir -> relPathDirToFile topdir dir0
- let relparts = map P.splitDirectories relps
+ let relparts = map splitDirectories relps
-- Catch cases where dir0 is not beneath a topdir.
-- If the relative path between them starts with "..",
-- it's not. And on Windows, if they are on different drives,
-- the path will not be relative.
let notbeneath = \(_topdir, (relp, dirs)) ->
- headMaybe dirs /= Just ".." && not (P.isAbsolute relp)
+ headMaybe dirs /= Just (literalOsPath "..") && not (isAbsolute relp)
case filter notbeneath $ zip topdirs (zip relps relparts) of
((topdir, (_relp, dirs)):_)
-- If dir0 is the same as the topdir, don't try to
-- create it, but make sure it does exist.
| null dirs ->
- liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $
+ liftIO $ unlessM (doesDirectoryExist topdir) $
ioError $ customerror doesNotExistErrorType $
- "createDirectoryUnder: " ++ fromRawFilePath topdir ++ " does not exist"
+ "createDirectoryUnder: " ++ fromOsPath topdir ++ " does not exist"
| otherwise -> createdirs $
- map (topdir P.</>) (reverse (scanl1 (P.</>) dirs))
+ map (topdir </>) (reverse (scanl1 (</>) dirs))
_ -> liftIO $ ioError $ customerror userErrorType
- ("createDirectoryUnder: not located in " ++ unwords (map fromRawFilePath topdirs))
+ ("createDirectoryUnder: not located in " ++ unwords (map fromOsPath topdirs))
where
- customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0))
+ customerror t s = mkIOError t s Nothing (Just (fromOsPath dir0))
createdirs [] = pure ()
createdirs (dir:[]) = createdir dir (liftIO . ioError)
Left e
| isDoesNotExistError e -> notexisthandler e
| isAlreadyExistsError e || isPermissionError e ->
- liftIO $ unlessM (doesDirectoryExist (fromRawFilePath dir)) $
+ liftIO $ unlessM (doesDirectoryExist dir) $
ioError e
| otherwise -> liftIO $ ioError e
import Control.Monad
import Control.Concurrent
-import qualified Data.ByteString as B
import Data.Maybe
import Prelude
import qualified System.Win32 as Win32
import System.FilePath
#else
+import qualified Data.ByteString as B
import qualified System.Posix.Directory.ByteString as Posix
#endif
import Utility.Directory
import Utility.Exception
import Utility.FileSystemEncoding
+import Utility.OsPath
#ifndef mingw32_HOST_OS
data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream
case v of
Nothing -> return False
Just f
- | not (dirCruft f) -> return True
+ | not (toOsPath f `elem` dirCruft) -> return True
| otherwise -> check h
(
withFile,
openFile,
+ withBinaryFile,
+ openBinaryFile,
readFile,
readFile',
writeFile,
-- https://github.com/haskell/file-io/issues/39
import Utility.Path.Windows
import Utility.OsPath
+import System.OsPath
import System.IO (IO, Handle, IOMode)
-import System.OsPath (OsPath)
+import Prelude (return)
import qualified System.File.OsPath as O
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
O.openFile f' m
+withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r
+withBinaryFile f m a = do
+ f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
+ O.withBinaryFile f' m a
+
+openBinaryFile :: OsPath -> IOMode -> IO Handle
+openBinaryFile f m = do
+ f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
+ O.openBinaryFile f' m
+
readFile :: OsPath -> IO L.ByteString
readFile f = do
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
openTempFile :: OsPath -> OsPath -> IO (OsPath, Handle)
openTempFile p s = do
p' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath p)
- O.openTempFile p' s
+ (t, h) <- O.openTempFile p' s
+ -- Avoid returning mangled path from convertToWindowsNativeNamespace
+ let t' = p </> takeFileName t
+ return (t', h)
#endif
#else
--- When not building with OsPath, export FilePath versions
--- instead. However, functions still use ByteString for the
--- file content in that case, unlike the Strings used by the Prelude.
+-- When not building with OsPath, export RawFilePath versions
+-- instead.
import Utility.OsPath
-import System.IO (withFile, openFile, openTempFile, IO)
+import Utility.FileSystemEncoding
+import System.IO (IO, Handle, IOMode)
+import Prelude ((.), return)
import qualified System.IO
-import Data.ByteString.Lazy (readFile, writeFile, appendFile)
import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+
+withFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r
+withFile = System.IO.withFile . fromRawFilePath
+
+openFile :: OsPath -> IOMode -> IO Handle
+openFile = System.IO.openFile . fromRawFilePath
+
+withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r
+withBinaryFile = System.IO.withBinaryFile . fromRawFilePath
+
+openBinaryFile :: OsPath -> IOMode -> IO Handle
+openBinaryFile = System.IO.openBinaryFile . fromRawFilePath
+
+readFile :: OsPath -> IO L.ByteString
+readFile = L.readFile . fromRawFilePath
readFile' :: OsPath -> IO B.ByteString
-readFile' = B.readFile
+readFile' = B.readFile . fromRawFilePath
+
+writeFile :: OsPath -> L.ByteString -> IO ()
+writeFile = L.writeFile . fromRawFilePath
writeFile' :: OsPath -> B.ByteString -> IO ()
-writeFile' = B.writeFile
+writeFile' = B.writeFile . fromRawFilePath
+
+appendFile :: OsPath -> L.ByteString -> IO ()
+appendFile = L.appendFile . fromRawFilePath
appendFile' :: OsPath -> B.ByteString -> IO ()
-appendFile' = B.appendFile
+appendFile' = B.appendFile . fromRawFilePath
+
+openTempFile :: OsPath -> OsPath -> IO (OsPath, Handle)
+openTempFile p s = do
+ (t, h) <- System.IO.openTempFile
+ (fromRawFilePath p)
+ (fromRawFilePath s)
+ return (toRawFilePath t, h)
#endif
import Control.Monad.Catch
import Utility.Exception
-import Utility.FileSystemEncoding
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import Utility.OsPath
{- Applies a conversion function to a file's mode. -}
-modifyFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO ()
+modifyFileMode :: OsPath -> (FileMode -> FileMode) -> IO ()
modifyFileMode f convert = void $ modifyFileMode' f convert
-modifyFileMode' :: RawFilePath -> (FileMode -> FileMode) -> IO FileMode
+modifyFileMode' :: OsPath -> (FileMode -> FileMode) -> IO FileMode
modifyFileMode' f convert = do
- s <- R.getFileStatus f
+ s <- R.getFileStatus f'
let old = fileMode s
let new = convert old
when (new /= old) $
- R.setFileMode f new
+ R.setFileMode f' new
return old
+ where
+ f' = fromOsPath f
{- Runs an action after changing a file's mode, then restores the old mode. -}
-withModifiedFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO a -> IO a
+withModifiedFileMode :: OsPath -> (FileMode -> FileMode) -> IO a -> IO a
withModifiedFileMode file convert a = bracket setup cleanup go
where
setup = modifyFileMode' file convert
]
{- Removes the write bits from a file. -}
-preventWrite :: RawFilePath -> IO ()
+preventWrite :: OsPath -> IO ()
preventWrite f = modifyFileMode f $ removeModes writeModes
{- Turns a file's owner write bit back on. -}
-allowWrite :: RawFilePath -> IO ()
+allowWrite :: OsPath -> IO ()
allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]
{- Turns a file's owner read bit back on. -}
-allowRead :: RawFilePath -> IO ()
+allowRead :: OsPath -> IO ()
allowRead f = modifyFileMode f $ addModes [ownerReadMode]
{- Allows owner and group to read and write to a file. -}
, ownerReadMode, groupReadMode
]
-groupWriteRead :: RawFilePath -> IO ()
+groupWriteRead :: OsPath -> IO ()
groupWriteRead f = modifyFileMode f $ addModes groupSharedModes
checkMode :: FileMode -> FileMode -> Bool
isExecutable :: FileMode -> Bool
isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0
-data ModeSetter = ModeSetter FileMode (RawFilePath -> IO ())
+data ModeSetter = ModeSetter FileMode (OsPath -> IO ())
{- Runs an action which should create the file, passing it the desired
- initial file mode. Then runs the ModeSetter's action on the file, which
- can adjust the initial mode if umask prevented the file from being
- created with the right mode. -}
-applyModeSetter :: Maybe ModeSetter -> RawFilePath -> (Maybe FileMode -> IO a) -> IO a
+applyModeSetter :: Maybe ModeSetter -> OsPath -> (Maybe FileMode -> IO a) -> IO a
applyModeSetter (Just (ModeSetter mode modeaction)) file a = do
r <- a (Just mode)
void $ tryIO $ modeaction file
stickyMode :: FileMode
stickyMode = 512
-setSticky :: RawFilePath -> IO ()
+setSticky :: OsPath -> IO ()
setSticky f = modifyFileMode f $ addModes [stickyMode]
#endif
- On a filesystem that does not support file permissions, this is the same
- as writeFile.
-}
-writeFileProtected :: RawFilePath -> String -> IO ()
+writeFileProtected :: OsPath -> String -> IO ()
writeFileProtected file content = writeFileProtected' file
(\h -> hPutStr h content)
-writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO ()
+writeFileProtected' :: OsPath -> (Handle -> IO ()) -> IO ()
writeFileProtected' file writer = bracket setup cleanup writer
where
setup = do
- h <- protectedOutput $ F.openFile (toOsPath file) WriteMode
+ h <- protectedOutput $ F.openFile file WriteMode
void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
return h
cleanup = hClose
#ifdef mingw32_HOST_OS
import Control.Exception (bracket)
import System.IO
-import Utility.FileSystemEncoding
import qualified Utility.FileIO as F
import Utility.OsPath
#else
#endif
import System.PosixCompat.Files (FileStatus)
import qualified Utility.RawFilePath as R
+import Utility.OsPath
type FileSize = Integer
- FileOffset which maxes out at 2 gb.
- See https://github.com/jystic/unix-compat/issues/16
-}
-getFileSize :: R.RawFilePath -> IO FileSize
+getFileSize :: OsPath -> IO FileSize
#ifndef mingw32_HOST_OS
-getFileSize f = fmap (fromIntegral . fileSize) (R.getFileStatus f)
+getFileSize f = fmap (fromIntegral . fileSize) (R.getFileStatus (fromOsPath f))
#else
-getFileSize f = bracket (F.openFile (toOsPath f) ReadMode) hClose hFileSize
+getFileSize f = bracket (F.openFile f ReadMode) hClose hFileSize
#endif
{- Gets the size of the file, when its FileStatus is already known.
-
- On windows, uses getFileSize. Otherwise, the FileStatus contains the
- size, so this does not do any work. -}
-getFileSize' :: R.RawFilePath -> FileStatus -> IO FileSize
+getFileSize' :: OsPath -> FileStatus -> IO FileSize
#ifndef mingw32_HOST_OS
getFileSize' _ s = return $ fromIntegral $ fileSize s
#else
go coll cnt bs
| cnt <= 0 = coll
| otherwise = case S8.decode bs of
- Just (c, x) | c /= S8.replacement_char ->
- let x' = fromIntegral x
- in if cnt - x' < 0
- then coll
- else go (c:coll) (cnt - x') (S8.drop 1 bs)
+ Just (c, x)
+ | c /= S8.replacement_char ->
+ let x' = fromIntegral x
+ in if cnt - x' < 0
+ then coll
+ else go (c:coll) (cnt - x') (S8.drop 1 bs)
+ | otherwise ->
+ go ('_':coll) (cnt - 1) (S8.drop 1 bs)
_ -> coll
#endif
- License: BSD-2-clause
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.FreeDesktop (
userDesktopDir
) where
-import Utility.Exception
+import Common
import Utility.UserInfo
-import Utility.Process
import System.Environment
-import System.FilePath
-import System.Directory
-import Data.List
-import Data.Maybe
-import Control.Applicative
-import Prelude
type DesktopEntry = [(Key, Value)]
where
keyvalue (k, v) = k ++ "=" ++ toString v
-writeDesktopMenuFile :: DesktopEntry -> String -> IO ()
+writeDesktopMenuFile :: DesktopEntry -> OsPath -> IO ()
writeDesktopMenuFile d file = do
createDirectoryIfMissing True (takeDirectory file)
- writeFile file $ buildDesktopMenuFile d
+ writeFile (fromOsPath file) $ buildDesktopMenuFile d
{- Path to use for a desktop menu file, in either the systemDataDir or
- the userDataDir -}
-desktopMenuFilePath :: String -> FilePath -> FilePath
+desktopMenuFilePath :: String -> OsPath -> OsPath
desktopMenuFilePath basename datadir =
- datadir </> "applications" </> desktopfile basename
+ datadir </> literalOsPath "applications" </> desktopfile basename
{- Path to use for a desktop autostart file, in either the systemDataDir
- or the userDataDir -}
-autoStartPath :: String -> FilePath -> FilePath
+autoStartPath :: String -> OsPath -> OsPath
autoStartPath basename configdir =
- configdir </> "autostart" </> desktopfile basename
+ configdir </> literalOsPath "autostart" </> desktopfile basename
{- Base directory to install an icon file, in either the systemDataDir
- or the userDatadir. -}
-iconDir :: FilePath -> FilePath
-iconDir datadir = datadir </> "icons" </> "hicolor"
+iconDir :: OsPath -> OsPath
+iconDir datadir = datadir </> literalOsPath "icons" </> literalOsPath "hicolor"
{- Filename of an icon, given the iconDir to use.
-
- The resolution is something like "48x48" or "scalable". -}
-iconFilePath :: FilePath -> String -> FilePath -> FilePath
+iconFilePath :: OsPath -> String -> OsPath -> OsPath
iconFilePath file resolution icondir =
- icondir </> resolution </> "apps" </> file
+ icondir </> toOsPath resolution </> literalOsPath "apps" </> file
-desktopfile :: FilePath -> FilePath
-desktopfile f = f ++ ".desktop"
+desktopfile :: FilePath -> OsPath
+desktopfile f = toOsPath $ f ++ ".desktop"
{- Directory used for installation of system wide data files.. -}
-systemDataDir :: FilePath
-systemDataDir = "/usr/share"
+systemDataDir :: OsPath
+systemDataDir = literalOsPath "/usr/share"
{- Directory used for installation of system wide config files. -}
-systemConfigDir :: FilePath
-systemConfigDir = "/etc/xdg"
+systemConfigDir :: OsPath
+systemConfigDir = literalOsPath "/etc/xdg"
{- Directory for user data files. -}
-userDataDir :: IO FilePath
-userDataDir = xdgEnvHome "DATA_HOME" ".local/share"
+userDataDir :: IO OsPath
+userDataDir = toOsPath <$> xdgEnvHome "DATA_HOME" ".local/share"
{- Directory for user config files. -}
-userConfigDir :: IO FilePath
-userConfigDir = xdgEnvHome "CONFIG_HOME" ".config"
+userConfigDir :: IO OsPath
+userConfigDir = toOsPath <$> xdgEnvHome "CONFIG_HOME" ".config"
{- Directory for the user's Desktop, may be localized.
-
xdgEnvHome :: String -> String -> IO String
xdgEnvHome envbase homedef = do
- home <- myHomeDir
- catchDefaultIO (home </> homedef) $
- getEnv $ "XDG_" ++ envbase
+ home <- toOsPath <$> myHomeDir
+ catchDefaultIO (fromOsPath $ home </> toOsPath homedef) $
+ getEnv ("XDG_" ++ envbase)
go (passphrasefd ++ params)
#else
-- store the passphrase in a temp file for gpg
- withTmpFile "gpg" $ \tmpfile h -> do
+ withTmpFile (toOsPath "gpg") $ \tmpfile h -> do
liftIO $ B.hPutStr h passphrase
liftIO $ hClose h
- let passphrasefile = [Param "--passphrase-file", File tmpfile]
+ let passphrasefile = [Param "--passphrase-file", File (fromOsPath tmpfile)]
go $ passphrasefile ++ params
#endif
where
setup = do
subdir <- makenewdir (1 :: Integer)
origenviron <- getEnvironment
- let environ = addEntry var subdir origenviron
+ let environ = addEntry var (fromOsPath subdir) origenviron
-- gpg is picky about permissions on its home dir
- liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath subdir) $
+ liftIO $ void $ tryIO $ modifyFileMode subdir $
removeModes $ otherGroupModes
-- For some reason, recent gpg needs a trustdb to be set up.
_ <- pipeStrict' cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] (Just environ) mempty
go Nothing = return Nothing
makenewdir n = do
- let subdir = tmpdir </> show n
+ let subdir = toOsPath tmpdir </> toOsPath (show n)
catchIOErrorType AlreadyExists (const $ makenewdir $ n + 1) $ do
createDirectory subdir
return subdir
import Author
import qualified Utility.FileIO as F
-import Utility.RawFilePath
import Utility.OsPath
import Text.HTML.TagSoup
-- It would be equivalent to use isHtml <$> readFile file,
-- but since that would not read all of the file, the handle
-- would remain open until it got garbage collected sometime later.
-isHtmlFile :: RawFilePath -> IO Bool
-isHtmlFile file = F.withFile (toOsPath file) ReadMode $ \h ->
+isHtmlFile :: OsPath -> IO Bool
+isHtmlFile file = F.withFile file ReadMode $ \h ->
isHtmlBs <$> B.hGet h htmlPrefixLength
-- | How much of the beginning of a html document is needed to detect it.
import Utility.TimeStamp
import Utility.QuickCheck
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import System.PosixCompat.Types
import System.PosixCompat.Files (isRegularFile, fileID)
return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t)
_ -> Nothing
-genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache)
+genInodeCache :: OsPath -> TSDelta -> IO (Maybe InodeCache)
genInodeCache f delta = catchDefaultIO Nothing $
- toInodeCache delta f =<< R.getSymbolicLinkStatus f
+ toInodeCache delta f =<< R.getSymbolicLinkStatus (fromOsPath f)
-toInodeCache :: TSDelta -> RawFilePath -> FileStatus -> IO (Maybe InodeCache)
+toInodeCache :: TSDelta -> OsPath -> FileStatus -> IO (Maybe InodeCache)
toInodeCache d f s = toInodeCache' d f s (fileID s)
-toInodeCache' :: TSDelta -> RawFilePath -> FileStatus -> FileID -> IO (Maybe InodeCache)
+toInodeCache' :: TSDelta -> OsPath -> FileStatus -> FileID -> IO (Maybe InodeCache)
toInodeCache' (TSDelta getdelta) f s inode
| isRegularFile s = do
delta <- getdelta
sz <- getFileSize' f s
#ifdef mingw32_HOST_OS
- mtime <- utcTimeToPOSIXSeconds <$> getModificationTime (fromRawFilePath f)
+ mtime <- utcTimeToPOSIXSeconds <$> getModificationTime f
#else
let mtime = Posix.modificationTimeHiRes s
#endif
- Its InodeCache at the time of its creation is written to the cache file,
- so changes can later be detected. -}
data SentinalFile = SentinalFile
- { sentinalFile :: RawFilePath
- , sentinalCacheFile :: RawFilePath
+ { sentinalFile :: OsPath
+ , sentinalCacheFile :: OsPath
}
deriving (Show)
writeSentinalFile :: SentinalFile -> IO ()
writeSentinalFile s = do
- writeFile (fromRawFilePath (sentinalFile s)) ""
- maybe noop (writeFile (fromRawFilePath (sentinalCacheFile s)) . showInodeCache)
+ F.writeFile' (sentinalFile s) mempty
+ maybe noop (writeFile (fromOsPath (sentinalCacheFile s)) . showInodeCache)
=<< genInodeCache (sentinalFile s) noTSDelta
data SentinalStatus = SentinalStatus
Just new -> return $ calc old new
where
loadoldcache = catchDefaultIO Nothing $
- readInodeCache <$> readFile (fromRawFilePath (sentinalCacheFile s))
+ readInodeCache <$> readFile (fromOsPath (sentinalCacheFile s))
gennewcache = genInodeCache (sentinalFile s) noTSDelta
calc (InodeCache (InodeCachePrim oldinode oldsize oldmtime)) (InodeCache (InodeCachePrim newinode newsize newmtime)) =
SentinalStatus (not unchanged) tsdelta
dummy = SentinalStatus True noTSDelta
sentinalFileExists :: SentinalFile -> IO Bool
-sentinalFileExists s = allM R.doesPathExist [sentinalCacheFile s, sentinalFile s]
+sentinalFileExists s = allM doesPathExist [sentinalCacheFile s, sentinalFile s]
instance Arbitrary InodeCache where
arbitrary =
import Utility.FileSystemEncoding
import Utility.Env
import Utility.Exception
+import Utility.OsPath
+import Utility.RawFilePath
import Data.Maybe
-import System.FilePath
-import System.Posix.Files
+import System.Posix.Files (isSymbolicLink)
import Data.Char
import Control.Monad.IfElse
import Control.Applicative
{- Installs a library. If the library is a symlink to another file,
- install the file it links to, and update the symlink to be relative. -}
installLib :: (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO (Maybe FilePath)
-installLib installfile top lib = ifM (doesFileExist lib)
+installLib installfile top lib = ifM (doesFileExist (toOsPath lib))
( do
installfile top lib
checksymlink lib
- return $ Just $ fromRawFilePath $ parentDir $ toRawFilePath lib
+ return $ Just $ fromOsPath $ parentDir $ toOsPath lib
, return Nothing
)
where
checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do
l <- readSymbolicLink (inTop top f)
let absl = absPathFrom
- (parentDir (toRawFilePath f))
- (toRawFilePath l)
- target <- relPathDirToFile (toRawFilePath (takeDirectory f)) absl
- installfile top (fromRawFilePath absl)
- removeWhenExistsWith removeLink (top ++ f)
- createSymbolicLink (fromRawFilePath target) (inTop top f)
- checksymlink (fromRawFilePath absl)
+ (parentDir (toOsPath f))
+ (toOsPath l)
+ target <- relPathDirToFile (takeDirectory (toOsPath f)) absl
+ installfile top (fromOsPath absl)
+ removeWhenExistsWith removeLink (toRawFilePath (top ++ f))
+ createSymbolicLink (fromOsPath target) (inTop top f)
+ checksymlink (fromOsPath absl)
-- Note that f is not relative, so cannot use </>
-inTop :: FilePath -> FilePath -> FilePath
-inTop top f = top ++ f
+inTop :: FilePath -> FilePath -> RawFilePath
+inTop top f = toRawFilePath $ top ++ f
{- Parse ldd output, getting all the libraries that the input files
- link to. Note that some of the libraries may not exist
import System.Posix.Process
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
-import qualified System.FilePath.ByteString as P
import Data.Maybe
import Data.List
import Network.BSD
-import System.FilePath
import Control.Applicative
import Prelude
-type PidLockFile = RawFilePath
+type PidLockFile = OsPath
data LockHandle
= LockHandle PidLockFile FileStatus SideLockHandle
| ParentLocked
-type SideLockHandle = Maybe (RawFilePath, Posix.LockHandle)
+type SideLockHandle = Maybe (OsPath, Posix.LockHandle)
data PidLock = PidLock
{ lockingPid :: ProcessID
readPidLock :: PidLockFile -> IO (Maybe PidLock)
readPidLock lockfile = (readish =<<)
- <$> catchMaybeIO (readFile (fromRawFilePath lockfile))
+ <$> catchMaybeIO (readFile (fromOsPath lockfile))
-- To avoid races when taking over a stale pid lock, a side lock is used.
-- This is a regular posix exclusive lock.
-- to take the side lock will only succeed once the file is
-- deleted, and so will be able to immediately see that it's taken
-- a stale lock.
- _ <- tryIO $ removeFile (fromRawFilePath f)
+ _ <- tryIO $ removeFile f
Posix.dropLock h
-- The side lock is put in /dev/shm. This will work on most any
-- Linux system, even if its whole root filesystem doesn't support posix
-- locks. /tmp is used as a fallback.
-sideLockFile :: PidLockFile -> IO RawFilePath
+sideLockFile :: PidLockFile -> IO OsPath
sideLockFile lockfile = do
- f <- fromRawFilePath <$> absPath lockfile
- let base = intercalate "_" (splitDirectories (makeRelative "/" f))
+ f <- absPath lockfile
+ let base = intercalate "_" $ map fromOsPath $
+ splitDirectories $ makeRelative (literalOsPath "/") f
let shortbase = reverse $ take 32 $ reverse base
let md5sum = if base == shortbase
then ""
- else toRawFilePath $ show (md5 (encodeBL base))
- dir <- ifM (doesDirectoryExist "/dev/shm")
- ( return "/dev/shm"
- , return "/tmp"
+ else show (md5 (encodeBL base))
+ dir <- ifM (doesDirectoryExist (literalOsPath "/dev/shm"))
+ ( return (literalOsPath "/dev/shm")
+ , return (literalOsPath "/tmp")
)
- return $ dir P.</> md5sum <> toRawFilePath shortbase <> ".lck"
+ return $ dir </> toOsPath md5sum <> toOsPath shortbase <> literalOsPath ".lck"
-- | Tries to take a lock; does not block when the lock is already held.
--
where
go abslockfile sidelock = do
(tmp, h) <- openTmpFileIn
- (toOsPath (P.takeDirectory abslockfile))
- (toOsPath "locktmp")
+ (takeDirectory abslockfile)
+ (literalOsPath "locktmp")
let tmp' = fromOsPath tmp
setFileMode tmp' (combineModes readModes)
hPutStr h . show =<< mkPidLock
hClose h
let failedlock = do
dropSideLock sidelock
- removeWhenExistsWith removeLink tmp'
+ removeWhenExistsWith removeFile tmp
return Nothing
let tooklock st = return $ Just $ LockHandle abslockfile st sidelock
- linkToLock sidelock tmp' abslockfile >>= \case
+ linkToLock sidelock tmp' (fromOsPath abslockfile) >>= \case
Just lckst -> do
- removeWhenExistsWith removeLink tmp'
+ removeWhenExistsWith removeFile tmp
tooklock lckst
Nothing -> do
v <- readPidLock abslockfile
-- the pidlock was taken on,
-- we know that the pidlock is
-- stale, and can take it over.
- rename tmp' abslockfile
+ rename tmp' (fromOsPath abslockfile)
tooklock tmpst
_ -> failedlock
Right _ -> do
_ <- tryIO $ createLink src dest
ifM (catchBoolIO checklinked)
- ( ifM (catchBoolIO $ not <$> checkInsaneLustre dest)
+ ( ifM (catchBoolIO $ not <$> checkInsaneLustre (toOsPath dest))
( catchMaybeIO $ getFileStatus dest
, return Nothing
)
-- We can detect this insanity by getting the directory contents after
-- making the link, and checking to see if 2 copies of the dest file,
-- with the SAME FILENAME exist.
-checkInsaneLustre :: RawFilePath -> IO Bool
+checkInsaneLustre :: OsPath -> IO Bool
checkInsaneLustre dest = do
- fs <- dirContents (P.takeDirectory dest)
+ fs <- dirContents (takeDirectory dest)
case length (filter (== dest) fs) of
1 -> return False -- whew!
0 -> return True -- wtf?
_ -> do
-- Try to clean up the extra copy we made
-- that has the same name. Egads.
- _ <- tryIO $ removeLink dest
+ _ <- tryIO $ removeFile dest
return True
-- | Waits as necessary to take a lock.
| n > 0 = liftIO (tryLock lockfile) >>= \case
Nothing -> do
when (n == pred timeout) $
- displaymessage $ "waiting for pid lock file " ++ fromRawFilePath lockfile ++ " which is held by another process (or may be stale)"
+ displaymessage $ "waiting for pid lock file " ++ fromOsPath lockfile ++ " which is held by another process (or may be stale)"
liftIO $ threadDelaySeconds (Seconds 1)
go (pred n)
Just lckh -> do
waitedLock :: MonadIO m => Seconds -> PidLockFile -> (String -> m ()) -> m a
waitedLock (Seconds timeout) lockfile displaymessage = do
- displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromRawFilePath lockfile
- giveup $ "Gave up waiting for pid lock file " ++ fromRawFilePath lockfile
+ displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromOsPath lockfile
+ giveup $ "Gave up waiting for pid lock file " ++ fromOsPath lockfile
-- | Use when the pid lock has already been taken by another thread of the
-- same process.
alreadyLocked :: MonadIO m => PidLockFile -> m LockHandle
alreadyLocked lockfile = liftIO $ do
abslockfile <- absPath lockfile
- st <- getFileStatus abslockfile
+ st <- getFileStatus (fromOsPath abslockfile)
return $ LockHandle abslockfile st Nothing
dropLock :: LockHandle -> IO ()
-- Drop side lock first, at which point the pid lock will be
-- considered stale.
dropSideLock sidelock
- removeWhenExistsWith removeLink lockfile
+ removeWhenExistsWith removeFile lockfile
dropLock ParentLocked = return ()
getLockStatus :: PidLockFile -> IO LockStatus
-- locked to get the LockHandle.
checkSaneLock :: PidLockFile -> LockHandle -> IO Bool
checkSaneLock lockfile (LockHandle _ st _) =
- go =<< catchMaybeIO (getFileStatus lockfile)
+ go =<< catchMaybeIO (getFileStatus (fromOsPath lockfile))
where
go Nothing = return False
go (Just st') = return $
-- The parent process should keep running as long as the child
-- process is running, since the child inherits the environment and will
-- not see unsetLockEnv.
-pidLockEnv :: RawFilePath -> IO String
+pidLockEnv :: OsPath -> IO String
pidLockEnv lockfile = do
- abslockfile <- fromRawFilePath <$> absPath lockfile
+ abslockfile <- fromOsPath <$> absPath lockfile
return $ "PIDLOCK_" ++ filter legalInEnvVar abslockfile
pidLockEnvValue :: String
import Utility.FileMode
import Utility.LockFile.LockStatus
import Utility.OpenFd
+import Utility.OsPath
import System.IO
import System.Posix.Types
import System.Posix.IO.ByteString
import System.Posix.Files.ByteString
-import System.FilePath.ByteString (RawFilePath)
import Data.Maybe
-type LockFile = RawFilePath
+type LockFile = OsPath
newtype LockHandle = LockHandle Fd
openLockFile :: LockRequest -> Maybe ModeSetter -> LockFile -> IO Fd
openLockFile lockreq filemode lockfile = do
l <- applyModeSetter filemode lockfile $ \filemode' ->
- openFdWithMode lockfile openfor filemode' defaultFileFlags
+ openFdWithMode (fromOsPath lockfile) openfor filemode' defaultFileFlags
setFdOption l CloseOnExec True
return l
where
-- else.
checkSaneLock :: LockFile -> LockHandle -> IO Bool
checkSaneLock lockfile (LockHandle fd) =
- go =<< catchMaybeIO (getFileStatus lockfile)
+ go =<< catchMaybeIO (getFileStatus (fromOsPath lockfile))
where
go Nothing = return False
go (Just st) = do
Right h -> Just h
#else
h <- withTString (fromRawFilePath f') $ \c_f ->
- c_CreateFile c_f gENERIC_READ sharemode security_attributes
+ c_CreateFile c_f gENERIC_READ sharemode (maybePtr Nothing)
oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing)
return $ if h == iNVALID_HANDLE_VALUE
then Nothing
else Just h
#endif
- where
- security_attributes = maybePtr Nothing
dropLock :: LockHandle -> IO ()
dropLock = closeHandle
) where
import Utility.Monad
+import Utility.OsPath
import System.IO.Unsafe (unsafePerformIO)
-import System.FilePath.ByteString (RawFilePath)
import qualified Data.Map.Strict as M
import Control.Concurrent.STM
import Control.Exception
-type LockFile = RawFilePath
+type LockFile = OsPath
data LockMode = LockExclusive | LockShared
deriving (Eq)
where
go num
| num > maxLogs = return ()
- | otherwise = whenM (doesFileExist currfile) $ do
+ | otherwise = whenM (doesFileExist (toOsPath currfile)) $ do
go (num + 1)
rename (toRawFilePath currfile) (toRawFilePath nextfile)
where
{- Lists most recent logs last. -}
listLogs :: FilePath -> IO [FilePath]
-listLogs logfile = filterM doesFileExist $ reverse $
+listLogs logfile = filterM (doesFileExist . toOsPath) $ reverse $
logfile : map (rotatedLog logfile) [1..maxLogs]
maxLogs :: Int
import Common
import BuildInfo
import Utility.Env.Set
+import qualified Utility.OsString as OS
import System.Posix.Types
- path where the program was found. Make sure at runtime that lsof is
- available, and if it's not in PATH, adjust PATH to contain it. -}
setup :: IO ()
-setup = do
- let cmd = fromMaybe "lsof" BuildInfo.lsof
- when (isAbsolute cmd) $ do
- path <- getSearchPath
- let path' = takeDirectory cmd : path
- setEnv "PATH" (intercalate [searchPathSeparator] path') True
+setup = when (isAbsolute cmd) $ do
+ path <- getSearchPath
+ let path' = fromOsPath $ OS.intercalate sep $
+ takeDirectory cmd : path
+ setEnv "PATH" path' True
+ where
+ cmd = toOsPath $ fromMaybe "lsof" BuildInfo.lsof
+ sep = OS.singleton searchPathSeparator
{- Checks each of the files in a directory to find open files.
- Note that this will find hard links to files elsewhere that are open. -}
import Utility.SimpleProtocol as Proto
import Utility.ThreadScheduler
import Utility.SafeOutput
+import qualified Utility.FileIO as F
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S
{- Sends the content of a file to an action, updating the meter as it's
- consumed. -}
-withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a
-withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h ->
+withMeteredFile :: OsPath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a
+withMeteredFile f meterupdate a = F.withBinaryFile f ReadMode $ \h ->
hGetContentsMetered h meterupdate >>= a
{- Calls the action repeatedly with chunks from the lazy ByteString.
meterupdate sofar'
go sofar' cs
-meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO ()
-meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h ->
+meteredWriteFile :: MeterUpdate -> OsPath -> L.ByteString -> IO ()
+meteredWriteFile meterupdate f b = F.withBinaryFile f WriteMode $ \h ->
meteredWrite meterupdate (S.hPut h) b
{- Applies an offset to a MeterUpdate. This can be useful when
-}
watchFileSize
:: (MonadIO m, MonadMask m)
- => RawFilePath
+ => OsPath
-> MeterUpdate
-> (MeterUpdate -> m a)
-> m a
import Utility.Tmp
import Utility.Exception
import Utility.Monad
-import Utility.FileSystemEncoding
import Utility.OsPath
import qualified Utility.RawFilePath as R
import Author
{- Moves one filename to another.
- First tries a rename, but falls back to moving across devices if needed. -}
-moveFile :: RawFilePath -> RawFilePath -> IO ()
-moveFile src dest = tryIO (R.rename src dest) >>= onrename
+moveFile :: OsPath -> OsPath -> IO ()
+moveFile src dest = tryIO (renamePath src dest) >>= onrename
where
onrename (Right _) = noop
onrename (Left e)
| isPermissionError e = rethrow
| isDoesNotExistError e = rethrow
- | otherwise = viaTmp mv (toOsPath dest) ()
+ | otherwise = viaTmp mv dest ()
where
rethrow = throwM e
mv tmp () = do
- let tmp' = fromRawFilePath (fromOsPath tmp)
-- copyFile is likely not as optimised as
-- the mv command, so we'll use the command.
--
whenM (isdir dest) rethrow
ok <- copyright =<< boolSystem "mv"
[ Param "-f"
- , Param (fromRawFilePath src)
- , Param tmp'
+ , Param (fromOsPath src)
+ , Param (fromOsPath tmp)
]
let e' = e
#else
- r <- tryIO $ copyFile (fromRawFilePath src) tmp'
+ r <- tryIO $ copyFile src tmp
let (ok, e') = case r of
Left err -> (False, err)
Right _ -> (True, e)
#endif
unless ok $ do
-- delete any partial
- _ <- tryIO $ removeFile tmp'
+ _ <- tryIO $ removeFile tmp
throwM e'
#ifndef mingw32_HOST_OS
isdir f = do
- r <- tryIO $ R.getSymbolicLinkStatus f
+ r <- tryIO $ R.getSymbolicLinkStatus (fromOsPath f)
case r of
(Left _) -> return False
(Right s) -> return $ isDirectory s
+#endif
copyright :: Copyright
copyright = author JoeyHess (2022-11)
-#endif
- License: BSD-2-clause
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.OSX (
genOSXAutoStartFile,
) where
+import Common
import Utility.UserInfo
-import System.FilePath
+autoStartBase :: String -> OsPath
+autoStartBase label = literalOsPath "Library"
+ </> literalOsPath "LaunchAgents"
+ </> toOsPath label <> literalOsPath ".plist"
-autoStartBase :: String -> FilePath
-autoStartBase label = "Library" </> "LaunchAgents" </> label ++ ".plist"
+systemAutoStart :: String -> OsPath
+systemAutoStart label = literalOsPath "/" </> autoStartBase label
-systemAutoStart :: String -> FilePath
-systemAutoStart label = "/" </> autoStartBase label
-
-userAutoStart :: String -> IO FilePath
+userAutoStart :: String -> IO OsPath
userAutoStart label = do
home <- myHomeDir
- return $ home </> autoStartBase label
+ return $ toOsPath home </> autoStartBase label
{- Generates an OSX autostart plist file with a given label, command, and
- params to run at boot or login. -}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.OsPath (
OsPath,
OsString,
+ RawFilePath,
+ literalOsPath,
+ stringToOsPath,
toOsPath,
fromOsPath,
+ module X,
+ getSearchPath,
+ unsafeFromChar,
) where
import Utility.FileSystemEncoding
-
+import Data.ByteString.Short (ShortByteString)
+import qualified Data.ByteString.Short as S
+import qualified Data.ByteString.Lazy as L
#ifdef WITH_OSPATH
+import System.OsPath as X hiding (OsPath, OsString, pack, unpack, unsafeFromChar)
import System.OsPath
import "os-string" System.OsString.Internal.Types
-import qualified Data.ByteString.Short as S
+import qualified System.FilePath.ByteString as PB
+#if defined(mingw32_HOST_OS)
+import GHC.IO (unsafePerformIO)
+import System.OsString.Encoding.Internal (cWcharsToChars_UCS2)
+import qualified System.OsString.Data.ByteString.Short.Word16 as BS16
+#endif
+#else
+import System.FilePath.ByteString as X hiding (RawFilePath, getSearchPath)
+import System.FilePath.ByteString (getSearchPath)
+import Data.ByteString (ByteString)
+import Data.Char
+import Data.Word
+#endif
-{- Unlike System.OsString.fromBytes, on Windows this does not ensure a
- - valid USC-2LE encoding. The input ByteString must be in a valid encoding
- - already or uses of the OsPath will fail. -}
-toOsPath :: RawFilePath -> OsPath
+class OsPathConv t where
+ toOsPath :: t -> OsPath
+ fromOsPath :: OsPath -> t
+
+instance OsPathConv FilePath where
+ toOsPath = toOsPath . toRawFilePath
+ fromOsPath = fromRawFilePath . fromOsPath
+
+#ifdef WITH_OSPATH
+instance OsPathConv RawFilePath where
#if defined(mingw32_HOST_OS)
-toOsPath = OsString . WindowsString . S.toShort
+ toOsPath = bytesToOsPath
+ fromOsPath = bytesFromOsPath
#else
-toOsPath = OsString . PosixString . S.toShort
+ toOsPath = bytesToOsPath . S.toShort
+ fromOsPath = S.fromShort . bytesFromOsPath
#endif
-fromOsPath :: OsPath -> RawFilePath
+instance OsPathConv ShortByteString where
#if defined(mingw32_HOST_OS)
-fromOsPath = S.fromShort . getWindowsString . getOsString
+ toOsPath = bytesToOsPath . S.fromShort
+ fromOsPath = S.toShort . bytesFromOsPath
#else
-fromOsPath = S.fromShort . getPosixString . getOsString
+ toOsPath = bytesToOsPath
+ fromOsPath = bytesFromOsPath
#endif
+instance OsPathConv L.ByteString where
+ toOsPath = toOsPath . L.toStrict
+ fromOsPath = L.fromStrict . fromOsPath
+
+#if defined(mingw32_HOST_OS)
+-- On Windows, OsString contains a ShortByteString that is
+-- utf-16 encoded. But the input RawFilePath is assumed to
+-- be utf-8. So this is a relatively expensive conversion.
+bytesToOsPath :: RawFilePath -> OsPath
+bytesToOsPath = unsafePerformIO . encodeFS . fromRawFilePath
#else
-{- When not building with WITH_OSPATH, use FilePath. This allows
- - using functions from legacy FilePath libraries interchangeably with
- - newer OsPath libraries.
+bytesToOsPath :: ShortByteString -> OsPath
+bytesToOsPath = OsString . PosixString
+#endif
+
+#if defined(mingw32_HOST_OS)
+bytesFromOsPath :: OsPath -> RawFilePath
+-- On Windows, OsString contains a ShortByteString that is
+-- utf-16 encoded, but RawFilePath is utf-8.
+-- So this is relatively expensive conversion.
+bytesFromOsPath = toRawFilePath . cWcharsToChars_UCS2 . BS16.unpack . getWindowsString . getOsString
+#else
+bytesFromOsPath :: OsPath -> ShortByteString
+bytesFromOsPath = getPosixString . getOsString
+#endif
+
+{- For some reason not included in System.OsPath -}
+getSearchPath :: IO [OsPath]
+getSearchPath = map toOsPath <$> PB.getSearchPath
+
+{- Used for string constants. Note that when using OverloadedStrings,
+ - the IsString instance for ShortByteString only works properly with
+ - ASCII characters. -}
+literalOsPath :: ShortByteString -> OsPath
+literalOsPath = toOsPath
+
+#else
+{- When not building with WITH_OSPATH, use RawFilePath.
-}
-type OsPath = FilePath
+type OsPath = RawFilePath
+
+type OsString = ByteString
-type OsString = String
+instance OsPathConv RawFilePath where
+ toOsPath = id
+ fromOsPath = id
-toOsPath :: RawFilePath -> OsPath
-toOsPath = fromRawFilePath
+instance OsPathConv ShortByteString where
+ toOsPath = S.fromShort
+ fromOsPath = S.toShort
-fromOsPath :: OsPath -> RawFilePath
-fromOsPath = toRawFilePath
+instance OsPathConv L.ByteString where
+ toOsPath = L.toStrict
+ fromOsPath = L.fromStrict
+
+unsafeFromChar :: Char -> Word8
+unsafeFromChar = fromIntegral . ord
+
+literalOsPath :: RawFilePath -> OsPath
+literalOsPath = id
#endif
+
+stringToOsPath :: String -> OsPath
+stringToOsPath = toOsPath
--- /dev/null
+{- OsString manipulation. Or ByteString when not built with OsString.
+ - Import qualified.
+ -
+ - Copyright 2025 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.OsString (
+ module X,
+ length,
+#ifndef WITH_OSPATH
+ toChar,
+#endif
+) where
+
+#ifdef WITH_OSPATH
+import System.OsString as X hiding (length)
+import qualified System.OsString
+import qualified Data.ByteString as B
+import Utility.OsPath
+import Prelude ((.), Int)
+
+{- Avoid System.OsString.length, which returns the number of code points on
+ - windows. This is the number of bytes. -}
+length :: System.OsString.OsString -> Int
+length = B.length . fromOsPath
+#else
+import Data.ByteString as X hiding (length)
+import Data.ByteString (length)
+import Data.Char
+import Data.Word
+import Prelude (fromIntegral, (.))
+
+toChar :: Word8 -> Char
+toChar = chr . fromIntegral
+#endif
searchPathContents,
) where
-import System.FilePath.ByteString
-import qualified System.FilePath as P
import qualified Data.ByteString as B
import Data.List
import Data.Maybe
import Utility.Monad
import Utility.SystemDirectory
import Utility.Exception
+import Utility.OsPath
+import qualified Utility.OsString as OS
#ifdef mingw32_HOST_OS
import Data.Char
- and removing the trailing path separator.
-
- On Windows, preserves whichever style of path separator might be used in
- - the input RawFilePaths. This is done because some programs in Windows
+ - the input paths. This is done because some programs in Windows
- demand a particular path separator -- and which one actually varies!
-
- This does not guarantee that two paths that refer to the same location,
- and are both relative to the same location (or both absolute) will
- - yield the same result. Run both through normalise from System.RawFilePath
+ - yield the same result. Run both through normalise from System.OsPath
- to ensure that.
-}
-simplifyPath :: RawFilePath -> RawFilePath
+simplifyPath :: OsPath -> OsPath
simplifyPath path = dropTrailingPathSeparator $
joinDrive drive $ joinPath $ norm [] $ splitPath path'
where
norm c [] = reverse c
norm c (p:ps)
- | p' == ".." && not (null c) && dropTrailingPathSeparator (c !! 0) /= ".." =
- norm (drop 1 c) ps
- | p' == "." = norm c ps
+ | p' == dotdot && not (null c)
+ && dropTrailingPathSeparator (c !! 0) /= dotdot =
+ norm (drop 1 c) ps
+ | p' == dot = norm c ps
| otherwise = norm (p:c) ps
where
p' = dropTrailingPathSeparator p
{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -}
-parentDir :: RawFilePath -> RawFilePath
+parentDir :: OsPath -> OsPath
parentDir = takeDirectory . dropTrailingPathSeparator
{- Just the parent directory of a path, or Nothing if the path has no
- parent (ie for "/" or "." or "foo") -}
-upFrom :: RawFilePath -> Maybe RawFilePath
+upFrom :: OsPath -> Maybe OsPath
upFrom dir
| length dirs < 2 = Nothing
| otherwise = Just $ joinDrive drive $
- B.intercalate (B.singleton pathSeparator) $ init dirs
+ OS.intercalate (OS.singleton pathSeparator) $ init dirs
where
-- on Unix, the drive will be "/" when the dir is absolute,
-- otherwise ""
(drive, path) = splitDrive dir
- dirs = filter (not . B.null) $ B.splitWith isPathSeparator path
+ dirs = filter (not . OS.null) $ OS.splitWith isPathSeparator path
-{- Checks if the first RawFilePath is, or could be said to contain the second.
+{- Checks if the first path is, or could be said to contain the second.
- For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
- are all equivalent.
-}
-dirContains :: RawFilePath -> RawFilePath -> Bool
+dirContains :: OsPath -> OsPath -> Bool
dirContains a b = a == b
|| a' == b'
- || (a'' `B.isPrefixOf` b' && avoiddotdotb)
- || a' == "." && normalise ("." </> b') == b' && nodotdot b'
+ || (a'' `OS.isPrefixOf` b' && avoiddotdotb)
+ || a' == dot && normalise (dot </> b') == b' && nodotdot b'
|| dotdotcontains
where
a' = norm a
- a'' is a prefix of b', so all that needs to be done is drop
- that prefix, and check if the next path component is ".."
-}
- avoiddotdotb = nodotdot $ B.drop (B.length a'') b'
+ avoiddotdotb = nodotdot $ OS.drop (OS.length a'') b'
nodotdot p = all (not . isdotdot) (splitPath p)
- isdotdot s = dropTrailingPathSeparator s == ".."
+ isdotdot s = dropTrailingPathSeparator s == dotdot
{- This handles the case where a is ".." or "../.." etc,
- and b is "foo" or "../foo" etc. The rule is that when
- we stop preserving ordering at that point. Presumably a user passing
- that many paths in doesn't care too much about order of the later ones.
-}
-segmentPaths :: (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[a]]
+segmentPaths :: (a -> OsPath) -> [OsPath] -> [a] -> [[a]]
segmentPaths = segmentPaths' (\_ r -> r)
-segmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[r]]
+segmentPaths' :: (Maybe OsPath -> a -> r) -> (a -> OsPath) -> [OsPath] -> [a] -> [[r]]
segmentPaths' f _ [] new = [map (f Nothing) new]
segmentPaths' f _ [i] new = [map (f (Just i)) new] -- optimisation
segmentPaths' f c (i:is) new =
- than it would be to run the action separately with each path. In
- the case of git file list commands, that assumption tends to hold.
-}
-runSegmentPaths :: (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[a]]
+runSegmentPaths :: (a -> OsPath) -> ([OsPath] -> IO [a]) -> [OsPath] -> IO [[a]]
runSegmentPaths c a paths = segmentPaths c paths <$> a paths
-runSegmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[r]]
+runSegmentPaths' :: (Maybe OsPath -> a -> r) -> (a -> OsPath) -> ([OsPath] -> IO [a]) -> [OsPath] -> IO [[r]]
runSegmentPaths' si c a paths = segmentPaths' si c paths <$> a paths
{- Checks if a filename is a unix dotfile. All files inside dotdirs
- count as dotfiles. -}
-dotfile :: RawFilePath -> Bool
+dotfile :: OsPath -> Bool
dotfile file
- | f == "." = False
- | f == ".." = False
- | f == "" = False
- | otherwise = "." `B.isPrefixOf` f || dotfile (takeDirectory file)
+ | f == dot = False
+ | f == dotdot = False
+ | f == literalOsPath "" = False
+ | otherwise = dot `OS.isPrefixOf` f || dotfile (takeDirectory file)
where
f = takeFileName file
-{- Similar to splitExtensions, but knows that some things in RawFilePaths
+{- Similar to splitExtensions, but knows that some things in paths
- after a dot are too long to be extensions. -}
-splitShortExtensions :: RawFilePath -> (RawFilePath, [B.ByteString])
+splitShortExtensions :: OsPath -> (OsPath, [B.ByteString])
splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"
-splitShortExtensions' :: Int -> RawFilePath -> (RawFilePath, [B.ByteString])
+splitShortExtensions' :: Int -> OsPath -> (OsPath, [B.ByteString])
splitShortExtensions' maxextension = go []
where
go c f
- | len > 0 && len <= maxextension && not (B.null base) =
- go (ext:c) base
+ | len > 0 && len <= maxextension && not (OS.null base) =
+ go (fromOsPath ext:c) base
| otherwise = (f, c)
where
(base, ext) = splitExtension f
- len = B.length ext
+ len = OS.length ext
{- This requires both paths to be absolute and normalized.
-
- a relative path is not possible and the path is simply
- returned as-is.
-}
-relPathDirToFileAbs :: RawFilePath -> RawFilePath -> RawFilePath
+relPathDirToFileAbs :: OsPath -> OsPath -> OsPath
relPathDirToFileAbs from to
#ifdef mingw32_HOST_OS
| normdrive from /= normdrive to = to
common = map fst $ takeWhile same $ zip pfrom pto
same (c,d) = c == d
uncommon = drop numcommon pto
- dotdots = replicate (length pfrom - numcommon) ".."
+ dotdots = replicate (length pfrom - numcommon) dotdot
numcommon = length common
#ifdef mingw32_HOST_OS
normdrive = map toLower
-- path separator, which takeDrive leaves on the drive
-- letter.
. dropWhileEnd (isPathSeparator . fromIntegral . ord)
- . fromRawFilePath
+ . fromOsPath
. takeDrive
#endif
-
- Note that this will find commands in PATH that are not executable.
-}
-searchPath :: String -> IO (Maybe FilePath)
+searchPath :: String -> IO (Maybe OsPath)
searchPath command
- | P.isAbsolute command = copyright $ check command
- | otherwise = P.getSearchPath >>= getM indir
+ | isAbsolute command' = copyright $ check command'
+ | otherwise = getSearchPath >>= getM indir
where
- indir d = check $ d P.</> command
+ command' = toOsPath command
+ indir d = check (d </> command')
check f = firstM doesFileExist
#ifdef mingw32_HOST_OS
- [f, f ++ ".exe"]
+ [f, f <> ".exe"]
#else
[f]
#endif
-
- Note that this will find commands in PATH that are not executable.
-}
-searchPathContents :: (FilePath -> Bool) -> IO [FilePath]
+searchPathContents :: (OsPath -> Bool) -> IO [OsPath]
searchPathContents p =
filterM doesFileExist
- =<< (concat <$> (P.getSearchPath >>= mapM go))
+ =<< (concat <$> (getSearchPath >>= mapM go))
where
- go d = map (d P.</>) . filter p
+ go d = map (d </>) . filter p
<$> catchDefaultIO [] (getDirectoryContents d)
+
+dot :: OsPath
+dot = literalOsPath "."
+
+dotdot :: OsPath
+dotdot = literalOsPath ".."
+
relHome,
) where
-import System.FilePath.ByteString
import qualified Data.ByteString as B
import Control.Applicative
import Prelude
import Utility.Path
import Utility.UserInfo
-import Utility.FileSystemEncoding
-import qualified Utility.RawFilePath as R
+import Utility.OsPath
+import Utility.SystemDirectory
{- Makes a path absolute.
-
- Does not attempt to deal with edge cases or ensure security with
- untrusted inputs.
-}
-absPathFrom :: RawFilePath -> RawFilePath -> RawFilePath
+absPathFrom :: OsPath -> OsPath -> OsPath
absPathFrom dir path = simplifyPath (combine dir path)
{- Converts a filename into an absolute path.
-
- Unlike Directory.canonicalizePath, this does not require the path
- already exists. -}
-absPath :: RawFilePath -> IO RawFilePath
+absPath :: OsPath -> IO OsPath
absPath file
-- Avoid unnecessarily getting the current directory when the path
-- is already absolute. absPathFrom uses simplifyPath
-- so also used here for consistency.
| isAbsolute file = return $ simplifyPath file
| otherwise = do
- cwd <- R.getCurrentDirectory
+ cwd <- getCurrentDirectory
return $ absPathFrom cwd file
{- Constructs the minimal relative path from the CWD to a file.
- relPathCwdToFile "/tmp/foo/bar" == ""
- relPathCwdToFile "../bar/baz" == "baz"
-}
-relPathCwdToFile :: RawFilePath -> IO RawFilePath
+relPathCwdToFile :: OsPath -> IO OsPath
relPathCwdToFile f
-- Optimisation: Avoid doing any IO when the path is relative
-- and does not contain any ".." component.
- | isRelative f && not (".." `B.isInfixOf` f) = return f
+ | isRelative f && not (".." `B.isInfixOf` fromOsPath f) = return f
| otherwise = do
- c <- R.getCurrentDirectory
+ c <- getCurrentDirectory
relPathDirToFile c f
{- Constructs a minimal relative path from a directory to a file. -}
-relPathDirToFile :: RawFilePath -> RawFilePath -> IO RawFilePath
+relPathDirToFile :: OsPath -> OsPath -> IO OsPath
relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
{- Converts paths in the home directory to use ~/ -}
-relHome :: FilePath -> IO String
+relHome :: OsPath -> IO OsPath
relHome path = do
- let path' = toRawFilePath path
- home <- toRawFilePath <$> myHomeDir
- return $ if dirContains home path'
- then fromRawFilePath ("~/" <> relPathDirToFileAbs home path')
+ home <- toOsPath <$> myHomeDir
+ return $ if dirContains home path
+ then literalOsPath "~/" <> relPathDirToFileAbs home path
else path
prop_dirContains_regressionTest,
) where
-import System.FilePath.ByteString
-import qualified Data.ByteString as B
import Data.List
import Data.Maybe
-import Data.Char
import Control.Applicative
import Prelude
-import Utility.Path
-import Utility.FileSystemEncoding
+import Common
import Utility.QuickCheck
+import qualified Utility.OsString as OS
prop_upFrom_basics :: TestableFilePath -> Bool
prop_upFrom_basics tdir
| dir == "/" = p == Nothing
| otherwise = p /= Just dir
where
- p = fromRawFilePath <$> upFrom (toRawFilePath dir)
+ p = fromOsPath <$> upFrom (toOsPath dir)
dir = fromTestableFilePath tdir
prop_relPathDirToFileAbs_basics :: TestableFilePath -> Bool
prop_relPathDirToFileAbs_basics pt = and
- [ relPathDirToFileAbs p (p </> "bar") == "bar"
- , relPathDirToFileAbs (p </> "bar") p == ".."
- , relPathDirToFileAbs p p == ""
+ [ relPathDirToFileAbs p (p </> literalOsPath "bar") == literalOsPath "bar"
+ , relPathDirToFileAbs (p </> literalOsPath "bar") p == literalOsPath ".."
+ , relPathDirToFileAbs p p == literalOsPath ""
]
where
-- relPathDirToFileAbs needs absolute paths, so make the path
-- absolute by adding a path separator to the front.
- p = pathSeparator `B.cons` relf
+ p = pathSeparator `OS.cons` relf
-- Make the input a relative path. On windows, make sure it does
-- not contain anything that looks like a drive letter.
- relf = B.dropWhile isPathSeparator $
- B.filter (not . skipchar) $
- toRawFilePath (fromTestableFilePath pt)
- skipchar b = b == (fromIntegral (ord ':'))
+ relf = OS.dropWhile isPathSeparator $
+ OS.filter (not . skipchar) $
+ toOsPath (fromTestableFilePath pt)
+ skipchar b = b == unsafeFromChar ':'
prop_relPathDirToFileAbs_regressionTest :: Bool
prop_relPathDirToFileAbs_regressionTest = same_dir_shortcurcuits_at_difference
- location, but it's not really the same directory.
- Code used to get this wrong. -}
same_dir_shortcurcuits_at_difference =
- relPathDirToFileAbs (joinPath [pathSeparator `B.cons` "tmp", "r", "lll", "xxx", "yyy", "18"])
- (joinPath [pathSeparator `B.cons` "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
- == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
+ relPathDirToFileAbs (mkp [fromOsPath (pathSeparator `OS.cons` literalOsPath "tmp"), "r", "lll", "xxx", "yyy", "18"])
+ (mkp [fromOsPath (pathSeparator `OS.cons` literalOsPath "tmp"), "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
+ == mkp ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
+ where
+ mkp = joinPath . map literalOsPath
prop_dirContains_regressionTest :: Bool
prop_dirContains_regressionTest = and
- [ not $ dirContains "." ".."
- , not $ dirContains ".." "../.."
- , dirContains "." "foo"
- , dirContains "." "."
- , dirContains ".." ".."
- , dirContains "../.." "../.."
- , dirContains "." "./foo"
- , dirContains ".." "../foo"
- , dirContains "../.." "../foo"
- , dirContains "../.." "../../foo"
- , not $ dirContains "../.." "../../.."
+ [ not $ dc "." ".."
+ , not $ dc ".." "../.."
+ , dc "." "foo"
+ , dc "." "."
+ , dc ".." ".."
+ , dc "../.." "../.."
+ , dc "." "./foo"
+ , dc ".." "../foo"
+ , dc "../.." "../foo"
+ , dc "../.." "../../foo"
+ , not $ dc "../.." "../../.."
]
+ where
+ dc x y = dirContains (literalOsPath x) (literalOsPath y)
) where
import Utility.Path
-import Utility.FileSystemEncoding
+import Utility.OsPath
+import Utility.SystemDirectory
-import System.FilePath.ByteString (combine)
import qualified Data.ByteString as B
import qualified System.FilePath.Windows.ByteString as P
-import System.Directory (getCurrentDirectory)
{- Convert a filepath to use Windows's native namespace.
- This avoids filesystem length limits.
| otherwise = do
-- Make absolute because any '.' and '..' in the path
-- will not be resolved once it's converted.
- cwd <- toRawFilePath <$> getCurrentDirectory
- let p = simplifyPath (combine cwd f)
+ cwd <- getCurrentDirectory
+ let p = fromOsPath (simplifyPath (combine cwd (toOsPath f)))
-- Normalize slashes.
let p' = P.normalise p
return (win32_file_namespace <> p')
P.setFileMode p' m
{- Using renamePath rather than the rename provided in unix-compat
- - because of this bug https://github.com/jacobstanley/unix-compat/issues/56-}
+ - because of this bug https://github.com/jacobstanley/unix-compat/issues/56 -}
rename :: RawFilePath -> RawFilePath -> IO ()
rename a b = D.renamePath (fromRawFilePath a) (fromRawFilePath b)
import Data.Char
import qualified Data.ByteString as S
+#ifdef WITH_OSPATH
+import qualified Utility.OsString as OS
+import Utility.OsPath
+#endif
+
class SafeOutputtable t where
safeOutput :: t -> t
instance SafeOutputtable S.ByteString where
safeOutput = S.filter (safeOutputChar . chr . fromIntegral)
+#ifdef WITH_OSPATH
+instance SafeOutputtable OsString where
+ safeOutput = OS.filter (safeOutputChar . toChar)
+#endif
+
safeOutputChar :: Char -> Bool
safeOutputChar c
| not (isControl c) = True
findShellCommand,
) where
+import Utility.OsPath
import Utility.SafeCommand
#ifdef mingw32_HOST_OS
import Utility.Path
-- parse it for shebang.
--
-- This has no effect on Unix.
-findShellCommand :: FilePath -> IO (FilePath, [CommandParam])
+findShellCommand :: OsPath -> IO (FilePath, [CommandParam])
findShellCommand f = do
#ifndef mingw32_HOST_OS
defcmd
#else
- l <- catchDefaultIO Nothing $ headMaybe . lines <$> readFile f
+ l <- catchDefaultIO Nothing $ headMaybe . lines <$> readFile (fromOsPath f)
case l of
Just ('#':'!':rest) -> case words rest of
[] -> defcmd
_ -> defcmd
#endif
where
- defcmd = return (f, [])
+ defcmd = return (fromOsPath f, [])
- License: BSD-2-clause
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Utility.SshConfig (
SshConfig(..),
Comment(..),
changeUserSshConfig :: (String -> String) -> IO ()
changeUserSshConfig modifier = do
sshdir <- sshDir
- let configfile = sshdir </> "config"
+ let configfile = sshdir </> literalOsPath "config"
whenM (doesFileExist configfile) $ do
c <- decodeBS . S8.unlines . fileLines'
- <$> F.readFile' (toOsPath (toRawFilePath configfile))
+ <$> F.readFile' configfile
let c' = modifier c
when (c /= c') $ do
-- If it's a symlink, replace the file it
-- points to.
f <- catchDefaultIO configfile (canonicalizePath configfile)
- viaTmp writeSshConfig (toOsPath (toRawFilePath f)) c'
+ viaTmp writeSshConfig f c'
writeSshConfig :: OsPath -> String -> IO ()
writeSshConfig f s = do
F.writeFile' f (linesFile' (encodeBS s))
- setSshConfigMode (fromOsPath f)
+ setSshConfigMode f
{- Ensure that the ssh config file lacks any group or other write bits,
- since ssh is paranoid about not working if other users can write
- If the chmod fails, ignore the failure, as it might be a filesystem like
- Android's that does not support file modes.
-}
-setSshConfigMode :: RawFilePath -> IO ()
+setSshConfigMode :: OsPath -> IO ()
setSshConfigMode f = void $ tryIO $ modifyFileMode f $
removeModes [groupWriteMode, otherWriteMode]
-sshDir :: IO FilePath
+sshDir :: IO OsPath
sshDir = do
home <- myHomeDir
- return $ home </> ".ssh"
+ return $ toOsPath home </> literalOsPath ".ssh"
import System.Posix.IO
#else
import Utility.Tmp
-import Utility.OsPath
#endif
import Utility.Tmp.Dir
import Author
- The directory does not really have to be empty, it just needs to be one
- that should not contain any files with names starting with "@".
-}
-newtype EmptyDirectory = EmptyDirectory FilePath
+newtype EmptyDirectory = EmptyDirectory OsPath
{- Encrypt using symmetric encryption with the specified password. -}
encryptSymmetric
{- Test a value round-trips through symmetric encryption and decryption. -}
test_encrypt_decrypt_Symmetric :: SOPCmd -> SOPCmd -> Password -> Armoring -> B.ByteString -> IO Bool
test_encrypt_decrypt_Symmetric a b password armoring v = catchBoolIO $
- withTmpDir (toOsPath "test") $ \d -> do
+ withTmpDir (literalOsPath "test") $ \d -> do
let ed = EmptyDirectory d
enc <- encryptSymmetric a password ed Nothing armoring
(`B.hPutStr` v) B.hGetContents
withTmpFile (toOsPath "sop") $ \tmpfile h -> do
liftIO $ B.hPutStr h password
liftIO $ hClose h
- let passwordfile = [Param $ "--with-password="++tmpfile]
+ let passwordfile = [Param $ "--with-password=" ++ fromOsPath tmpfile]
-- Don't need to pass emptydirectory since @FD is not used,
-- and so tmpfile also does not need to be made absolute.
case emptydirectory of
, std_out = CreatePipe
, std_err = Inherit
, cwd = case med of
- Just (EmptyDirectory d) -> Just d
+ Just (EmptyDirectory d) -> Just (fromOsPath d)
Nothing -> Nothing
}
copyright =<< bracket (setup p) cleanup (go p)
mkSuCommand :: String -> [CommandParam] -> IO (Maybe SuCommand)
#ifndef mingw32_HOST_OS
mkSuCommand cmd ps = do
- pwd <- getCurrentDirectory
+ pwd <- fromOsPath <$> getCurrentDirectory
firstM (\(SuCommand _ p _) -> inSearchPath p) =<< selectcmds pwd
where
selectcmds pwd = ifM (inx <||> (not <$> atconsole))
-{- System.Directory without its conflicting isSymbolicLink and getFileSize.
+{- System.Directory wrapped to use OsPath.
+ -
+ - getFileSize is omitted, use Utility.FileSize instead
-
- Copyright 2016 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
--- Disable warnings because only some versions of System.Directory export
--- isSymbolicLink.
-{-# OPTIONS_GHC -fno-warn-tabs -w #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.SystemDirectory (
- module System.Directory
+ createDirectory,
+ createDirectoryIfMissing,
+ removeDirectory,
+ removeDirectoryRecursive,
+ removePathForcibly,
+ renameDirectory,
+ listDirectory,
+ getDirectoryContents,
+ getCurrentDirectory,
+ setCurrentDirectory,
+ withCurrentDirectory,
+ getTemporaryDirectory,
+ removeFile,
+ renameFile,
+ renamePath,
+ copyFile,
+ canonicalizePath,
+ doesPathExist,
+ doesFileExist,
+ doesDirectoryExist,
+ getModificationTime,
) where
-import System.Directory hiding (isSymbolicLink, getFileSize)
+#ifdef WITH_OSPATH
+import System.Directory.OsPath
+#else
+import qualified System.Directory as X
+import Data.Time.Clock (UTCTime)
+import Utility.OsPath
+import Utility.FileSystemEncoding
+
+createDirectory :: OsPath -> IO ()
+createDirectory = X.createDirectory . fromRawFilePath
+
+createDirectoryIfMissing :: Bool -> OsPath -> IO ()
+createDirectoryIfMissing b = X.createDirectoryIfMissing b . fromRawFilePath
+
+removeDirectory :: OsPath -> IO ()
+removeDirectory = X.removeDirectory . fromRawFilePath
+
+removeDirectoryRecursive :: OsPath -> IO ()
+removeDirectoryRecursive = X.removeDirectoryRecursive . fromRawFilePath
+
+removePathForcibly :: OsPath -> IO ()
+removePathForcibly = X.removePathForcibly . fromRawFilePath
+
+renameDirectory :: OsPath -> OsPath -> IO ()
+renameDirectory a b = X.renameDirectory (fromRawFilePath a) (fromRawFilePath b)
+
+listDirectory :: OsPath -> IO [OsPath]
+listDirectory p = map toRawFilePath <$> X.listDirectory (fromRawFilePath p)
+
+getDirectoryContents :: OsPath -> IO [OsPath]
+getDirectoryContents p = map toRawFilePath <$> X.getDirectoryContents (fromRawFilePath p)
+
+getCurrentDirectory :: IO OsPath
+getCurrentDirectory = toRawFilePath <$> X.getCurrentDirectory
+
+setCurrentDirectory :: OsPath -> IO ()
+setCurrentDirectory = X.setCurrentDirectory . fromRawFilePath
+
+withCurrentDirectory :: OsPath -> IO a -> IO a
+withCurrentDirectory = X.withCurrentDirectory . fromRawFilePath
+
+getTemporaryDirectory :: IO OsPath
+getTemporaryDirectory = toRawFilePath <$> X.getTemporaryDirectory
+
+removeFile :: OsPath -> IO ()
+removeFile = X.removeFile . fromRawFilePath
+
+renameFile :: OsPath -> OsPath -> IO ()
+renameFile a b = X.renameFile (fromRawFilePath a) (fromRawFilePath b)
+
+renamePath :: OsPath -> OsPath -> IO ()
+renamePath a b = X.renamePath (fromRawFilePath a) (fromRawFilePath b)
+
+copyFile :: OsPath -> OsPath -> IO ()
+copyFile a b = X.copyFile (fromRawFilePath a) (fromRawFilePath b)
+
+canonicalizePath :: OsPath -> IO OsPath
+canonicalizePath p = toRawFilePath <$> X.canonicalizePath (fromRawFilePath p)
+
+doesPathExist :: OsPath -> IO Bool
+doesPathExist = X.doesPathExist . fromRawFilePath
+
+doesFileExist :: OsPath -> IO Bool
+doesFileExist = X.doesFileExist . fromRawFilePath
+
+doesDirectoryExist :: OsPath -> IO Bool
+doesDirectoryExist = X.doesDirectoryExist . fromRawFilePath
+
+getModificationTime :: OsPath -> IO UTCTime
+getModificationTime = X.getModificationTime . fromRawFilePath
+#endif
-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Tmp (
) where
import System.IO
-import System.Directory
import Control.Monad.IO.Class
import System.IO.Error
import Data.Char
import qualified Data.ByteString as B
-import qualified System.FilePath.ByteString as P
import Utility.Exception
import Utility.FileSystemEncoding
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import Utility.OsPath
+import Utility.SystemDirectory
type Template = OsString
viaTmp :: (MonadMask m, MonadIO m) => (OsPath -> v -> m ()) -> OsPath -> v -> m ()
viaTmp a file content = bracketIO setup cleanup use
where
- (dir, base) = P.splitFileName (fromOsPath file)
- template = relatedTemplate (base <> ".tmp")
+ (dir, base) = splitFileName file
+ template = relatedTemplate (fromOsPath base <> ".tmp")
setup = do
- createDirectoryIfMissing True (fromRawFilePath dir)
- openTmpFileIn (toOsPath dir) template
+ createDirectoryIfMissing True dir
+ openTmpFileIn dir template
cleanup (tmpfile, h) = do
_ <- tryIO $ hClose h
- tryIO $ R.removeLink (fromOsPath tmpfile)
+ tryIO $ removeFile tmpfile
use (tmpfile, h) = do
let tmpfile' = fromOsPath tmpfile
-- Make mode the same as if the file were created usually,
- (or in "." if there is none) then removes the file. -}
withTmpFile :: (MonadIO m, MonadMask m) => Template -> (OsPath -> Handle -> m a) -> m a
withTmpFile template a = do
- tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
- withTmpFileIn (toOsPath (toRawFilePath tmpdir)) template a
+ tmpdir <- liftIO $ catchDefaultIO (literalOsPath ".") getTemporaryDirectory
+ withTmpFileIn tmpdir template a
{- Runs an action with a tmp file located in the specified directory,
- then removes the file.
create = liftIO $ openTmpFileIn tmpdir template
remove (name, h) = liftIO $ do
hClose h
- tryIO $ R.removeLink (fromOsPath name)
+ tryIO $ removeFile name
use (name, h) = a name h
{- It's not safe to use a FilePath of an existing file as the template
relatedTemplate = toOsPath . relatedTemplate'
relatedTemplate' :: RawFilePath -> RawFilePath
+#ifndef mingw32_HOST_OS
relatedTemplate' f
| len > templateAddedLength =
{- Some filesystems like FAT have issues with filenames
where
len = B.length f
dot = fromIntegral (ord '.')
+#else
+-- Avoids a test suite failure on windows, reason unknown, but
+-- best to keep paths short on windows anyway.
+relatedTemplate' _ = "t"
+#endif
{- When a Template is used to create a temporary file, some random bytes
- are appended to it. This is how many such bytes can be added, maximum.
{- Temporary directories
-
- - Copyright 2010-2022 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2025 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
+{-# LANGUAGE OverloadedStrings #-}
module Utility.Tmp.Dir (
withTmpDir,
) where
import Control.Monad.IfElse
-import System.FilePath
-import System.Directory
import Control.Monad.IO.Class
#ifndef mingw32_HOST_OS
import System.Posix.Temp (mkdtemp)
import Utility.Exception
import Utility.Tmp (Template)
import Utility.OsPath
-import Utility.FileSystemEncoding
+import Utility.SystemDirectory
{- Runs an action with a tmp directory located within the system's tmp
- directory (or within "." if there is none), then removes the tmp
- directory and all its contents. -}
-withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a
+withTmpDir :: (MonadMask m, MonadIO m) => Template -> (OsPath -> m a) -> m a
withTmpDir template a = do
- topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
+ topleveltmpdir <- liftIO $
+ catchDefaultIO (literalOsPath ".") getTemporaryDirectory
+ let p = fromOsPath $ topleveltmpdir </> template
#ifndef mingw32_HOST_OS
-- Use mkdtemp to create a temp directory securely in /tmp.
bracket
- (liftIO $ mkdtemp $ topleveltmpdir </> fromRawFilePath (fromOsPath template))
+ (liftIO $ toOsPath <$> mkdtemp p)
removeTmpDir
a
#else
{- Runs an action with a tmp directory located within a specified directory,
- then removes the tmp directory and all its contents. -}
-withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a
+withTmpDirIn :: (MonadMask m, MonadIO m) => OsPath -> Template -> (OsPath -> m a) -> m a
withTmpDirIn tmpdir template = bracketIO create removeTmpDir
where
create = do
createDirectoryIfMissing True tmpdir
- makenewdir (tmpdir </> fromRawFilePath (fromOsPath template)) (0 :: Int)
+ makenewdir (tmpdir </> template) (0 :: Int)
makenewdir t n = do
- let dir = t ++ "." ++ show n
+ let dir = t <> toOsPath ("." ++ show n)
catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do
createDirectory dir
return dir
{- Deletes the entire contents of the the temporary directory, if it
- exists. -}
-removeTmpDir :: MonadIO m => FilePath -> m ()
+removeTmpDir :: MonadIO m => OsPath -> m ()
removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do
#if mingw32_HOST_OS
-- Windows will often refuse to delete a file
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Utility.Tor (
OnionPort,
OnionAddress(..),
import Utility.ThreadScheduler
import Utility.FileMode
import Utility.RawFilePath (setOwnerAndGroup)
+import qualified Utility.OsString as OS
import System.PosixCompat.Types
import System.PosixCompat.Files (ownerReadMode, ownerWriteMode, ownerExecuteMode)
newtype OnionAddress = OnionAddress String
deriving (Show, Eq)
-type OnionSocket = FilePath
+type OnionSocket = OsPath
-- | A unique identifier for a hidden service.
type UniqueIdent = String
addHiddenService :: AppName -> UserID -> UniqueIdent -> IO (OnionAddress, OnionPort)
addHiddenService appname uid ident = do
prepHiddenServiceSocketDir appname uid ident
- ls <- lines <$> (readFile =<< findTorrc)
+ ls <- lines <$> (readFile . fromOsPath =<< findTorrc)
let portssocks = mapMaybe (parseportsock . separate isSpace) ls
- case filter (\(_, s) -> s == sockfile) portssocks of
+ case filter (\(_, s) -> s == fromOsPath sockfile) portssocks of
((p, _s):_) -> waithiddenservice 1 p
_ -> do
highports <- R.getStdRandom mkhighports
let newport = fromMaybe (error "internal") $ headMaybe $
filter (`notElem` map fst portssocks) highports
torrc <- findTorrc
- writeFile torrc $ unlines $
+ writeFile (fromOsPath torrc) $ unlines $
ls ++
[ ""
- , "HiddenServiceDir " ++ hiddenServiceDir appname uid ident
+ , "HiddenServiceDir " ++ fromOsPath (hiddenServiceDir appname uid ident)
, "HiddenServicePort " ++ show newport ++
- " unix:" ++ sockfile
+ " unix:" ++ fromOsPath sockfile
]
-- Reload tor, so it will see the new hidden
-- service and generate the hostname file for it.
waithiddenservice :: Int -> OnionPort -> IO (OnionAddress, OnionPort)
waithiddenservice 0 _ = giveup "tor failed to create hidden service, perhaps the tor service is not running"
waithiddenservice n p = do
- v <- tryIO $ readFile $ hiddenServiceHostnameFile appname uid ident
+ v <- tryIO $ readFile $ fromOsPath $
+ hiddenServiceHostnameFile appname uid ident
case v of
Right s | ".onion\n" `isSuffixOf` s ->
return (OnionAddress (takeWhile (/= '\n') s), p)
-- Has to be inside the torLibDir so tor can create it.
--
-- Has to end with "uid_ident" so getHiddenServiceSocketFile can find it.
-hiddenServiceDir :: AppName -> UserID -> UniqueIdent -> FilePath
-hiddenServiceDir appname uid ident = torLibDir </> appname ++ "_" ++ show uid ++ "_" ++ ident
+hiddenServiceDir :: AppName -> UserID -> UniqueIdent -> OsPath
+hiddenServiceDir appname uid ident =
+ torLibDir </> toOsPath (appname ++ "_" ++ show uid ++ "_" ++ ident)
-hiddenServiceHostnameFile :: AppName -> UserID -> UniqueIdent -> FilePath
-hiddenServiceHostnameFile appname uid ident = hiddenServiceDir appname uid ident </> "hostname"
+hiddenServiceHostnameFile :: AppName -> UserID -> UniqueIdent -> OsPath
+hiddenServiceHostnameFile appname uid ident =
+ hiddenServiceDir appname uid ident </> literalOsPath "hostname"
-- | Location of the socket for a hidden service.
--
-- Note that some unix systems limit socket paths to 92 bytes long.
-- That should not be a problem if the UniqueIdent is around the length of
-- a UUID, and the AppName is short.
-hiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> FilePath
-hiddenServiceSocketFile appname uid ident = varLibDir </> appname </> show uid ++ "_" ++ ident </> "s"
+hiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> OsPath
+hiddenServiceSocketFile appname uid ident =
+ varLibDir </> toOsPath appname
+ </> toOsPath (show uid ++ "_" ++ ident) </> literalOsPath "s"
-- | Parse torrc, to get the socket file used for a hidden service with
-- the specified UniqueIdent.
-getHiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> IO (Maybe FilePath)
+getHiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> IO (Maybe OsPath)
getHiddenServiceSocketFile _appname uid ident =
- parse . map words . lines <$> catchDefaultIO "" (readFile =<< findTorrc)
+ parse . map words . lines <$> catchDefaultIO ""
+ (readFile . fromOsPath =<< findTorrc)
where
parse [] = Nothing
parse (("HiddenServiceDir":hsdir:[]):("HiddenServicePort":_hsport:hsaddr:[]):rest)
- | "unix:" `isPrefixOf` hsaddr && hasident hsdir =
- Just (drop (length "unix:") hsaddr)
+ | "unix:" `isPrefixOf` hsaddr && hasident (toOsPath hsdir) =
+ Just $ toOsPath $ drop (length ("unix:" :: String)) hsaddr
| otherwise = parse rest
parse (_:rest) = parse rest
-- Don't look for AppName in the hsdir, because it didn't used to
-- be included.
- hasident hsdir = (show uid ++ "_" ++ ident) `isSuffixOf` takeFileName hsdir
+ hasident hsdir = toOsPath (show uid ++ "_" ++ ident) `OS.isSuffixOf` takeFileName hsdir
-- | Sets up the directory for the socketFile, with appropriate
-- permissions. Must run as root.
prepHiddenServiceSocketDir :: AppName -> UserID -> UniqueIdent -> IO ()
prepHiddenServiceSocketDir appname uid ident = do
createDirectoryIfMissing True d
- setOwnerAndGroup (toRawFilePath d) uid (-1)
- modifyFileMode (toRawFilePath d) $
+ setOwnerAndGroup (fromOsPath d) uid (-1)
+ modifyFileMode d $
addModes [ownerReadMode, ownerExecuteMode, ownerWriteMode]
where
d = takeDirectory $ hiddenServiceSocketFile appname uid ident
-- | Finds the system's torrc file, in any of the typical locations of it.
-- Returns the first found. If there is no system torrc file, defaults to
-- /etc/tor/torrc.
-findTorrc :: IO FilePath
-findTorrc = fromMaybe "/etc/tor/torrc" <$> firstM doesFileExist
- -- Debian
- [ "/etc/tor/torrc"
+findTorrc :: IO OsPath
+findTorrc = fromMaybe deftorrc <$> firstM doesFileExist
+ [ deftorrc
-- Some systems put it here instead.
- , "/etc/torrc"
+ , literalOsPath "/etc/torrc"
-- Default when installed from source
- , "/usr/local/etc/tor/torrc"
+ , literalOsPath "/usr/local/etc/tor/torrc"
]
+ where
+ -- Debian uses this
+ deftorrc = literalOsPath "/etc/tor/torrc"
-torLibDir :: FilePath
-torLibDir = "/var/lib/tor"
+torLibDir :: OsPath
+torLibDir = literalOsPath "/var/lib/tor"
-varLibDir :: FilePath
-varLibDir = "/var/lib"
+varLibDir :: OsPath
+varLibDir = literalOsPath "/var/lib"
torIsInstalled :: IO Bool
torIsInstalled = inSearchPath "tor"
import qualified Utility.RawFilePath as R
import Utility.Hash (IncrementalVerifier(..))
import Utility.Url.Parse
+import qualified Utility.FileIO as F
import Network.URI
import Network.HTTP.Types
=<< curlRestrictedParams r u defport (basecurlparams url')
existsfile u = do
- let f = toRawFilePath (unEscapeString (uriPath u))
- s <- catchMaybeIO $ R.getSymbolicLinkStatus f
+ let f = toOsPath (unEscapeString (uriPath u))
+ s <- catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath f)
case s of
Just stat -> do
sz <- getFileSize' f stat
-
- When the download fails, returns an error message.
-}
-download :: MeterUpdate -> Maybe IncrementalVerifier -> URLString -> FilePath -> UrlOptions -> IO (Either String ())
+download :: MeterUpdate -> Maybe IncrementalVerifier -> URLString -> OsPath -> UrlOptions -> IO (Either String ())
download = download' False
-download' :: Bool -> MeterUpdate -> Maybe IncrementalVerifier -> URLString -> FilePath -> UrlOptions -> IO (Either String ())
+download' :: Bool -> MeterUpdate -> Maybe IncrementalVerifier -> URLString -> OsPath -> UrlOptions -> IO (Either String ())
download' nocurlerror meterupdate iv url file uo =
catchJust matchHttpException go showhttpexception
`catchNonAsync` (dlfailed . show)
-- curl does not create destination file
-- if the url happens to be empty, so pre-create.
unlessM (doesFileExist file) $
- writeFile file ""
- ifM (boolSystem "curl" (curlparams ++ [Param "-o", File file, File rawurl]))
+ F.writeFile file mempty
+ ifM (boolSystem "curl" (curlparams ++ [Param "-o", File (fromOsPath file), File rawurl]))
( return $ Right ()
, return $ Left "download failed"
)
downloadfile u = do
noverification
- let src = unEscapeString (uriPath u)
+ let src = toOsPath $ unEscapeString (uriPath u)
withMeteredFile src meterupdate $
- L.writeFile file
+ F.writeFile file
return $ Right ()
-- Conduit does not support ftp, so will throw an exception on a
- thrown for reasons other than http status codes will still be thrown
- as usual.)
-}
-downloadConduit :: MeterUpdate -> Maybe IncrementalVerifier -> Request -> FilePath -> UrlOptions -> IO ()
+downloadConduit :: MeterUpdate -> Maybe IncrementalVerifier -> Request -> OsPath -> UrlOptions -> IO ()
downloadConduit meterupdate iv req file uo =
- catchMaybeIO (getFileSize (toRawFilePath file)) >>= \case
+ catchMaybeIO (getFileSize file) >>= \case
Just sz | sz > 0 -> resumedownload sz
_ -> join $ runResourceT $ do
liftIO $ debug "Utility.Url" (show req')
=> MeterUpdate
-> Maybe IncrementalVerifier
-> BytesProcessed
- -> FilePath
+ -> OsPath
-> IOMode
-> Response (ConduitM () B8.ByteString m ())
-> m ()
return (const noop)
(Just iv', _) -> return (updateIncrementalVerifier iv')
(Nothing, _) -> return (const noop)
- (fr, fh) <- allocate (openBinaryFile file mode) hClose
+ (fr, fh) <- allocate (F.openBinaryFile file mode) hClose
runConduit $ responseBody resp .| go ui initialp fh
release fr
where
{- Creates a html shim file that's used to redirect into the webapp,
- to avoid exposing the secret token when launching the web browser. -}
-writeHtmlShim :: String -> String -> FilePath -> IO ()
+writeHtmlShim :: String -> String -> OsPath -> IO ()
writeHtmlShim title url file =
- viaTmp (writeFileProtected . fromOsPath)
- (toOsPath $ toRawFilePath file)
- (genHtmlShim title url)
+ viaTmp (writeFileProtected) file (genHtmlShim title url)
genHtmlShim :: String -> String -> String
genHtmlShim title url = unlines
Utility.OptParse
Utility.OSX
Utility.OsPath
+ Utility.OsString
Utility.PID
Utility.PartialPrelude
Utility.Path
projects / git-annex.git / commitdiff